Return to DDS5.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DDS5.m, revision 1.1.1.1

1.1       snw         1: DDS5   ;SFISC/MKO-MULTS,NEXT/PREV PAGE,NEXT BLOCK ;10:39 AM  25 Oct 1994
                      2:        ;;21.0;VA FileMan;;Dec 28, 1994
                      3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
                      4:        I X="" D:DDSOLD="" NF^DDS01 D:DDSOLD]"" DM^DDS6 Q
                      5:        I DIR0N,$D(DUZ)#2 S ^DISV(DUZ,$E(DDSGL,1,28))=$E(DDSGL,29,999)_X
                      6:        I $G(@DDSREFS@("ASUB",DDSPG,DDSBK,DDO))]"" S DDS5PG=^(DDO)
                      7:        E  I $P($G(DDSO(7)),U,2)="" D:X=DDSOLD NF^DDS01 Q
                      8:        D MULT,R^DDSR
                      9:        ;
                     10:        K DDSSTACK
                     11:        X:$G(^DIST(.404,DDSBK,40,DDO,10))'?."^" ^(10)
                     12:        I $D(DDSSTACK) D ^DDSSTK,R^DDS3 K DDSBR
                     13:        D:$D(DDSBR)#2 BR^DDS2
                     14:        Q
                     15: MULT   ;
                     16:        N DIE,DDO,DDSBK,DDSDN,DDSNP,DDSOPB,DDSPG,DDSPTB,DDSREP,DDSTP
                     17:        ;
                     18:        I $G(DDS5PG) S DDSPG=DDS5PG K DDS5PG
                     19:        E  D
                     20:        . S DDSPG(1)=$P($G(DDSO(7)),U,2) Q:DDSPG(1)=""
                     21:        . S DDSPG=$O(^DIST(.403,+DDS,40,"B",DDSPG(1),"")) Q:DDSPG=""
                     22:        Q:$D(^DIST(.403,+DDS,40,+$G(DDSPG),0))[0
                     23:        N:'$P(^(0),U,6) DDSSC
                     24:        ;
                     25:        D DDA(Y,.DA,.DDSDL)
                     26:        I Y'=-1 D
                     27:        . N DDP,DDSDA,DDSFLD,DDSDLORG,DDSDAORG,DDSFLORG
                     28:        . S DIE=U_$P(DDSU("M"),U,2),DDP=$P(DDSU("M"),U,3)
                     29:        . S DDSDLORG=DDSDL,DDSDAORG=DA,DDSDA=DA_","
                     30:        . F DDSI=1:1:DDSDL S DDSDAORG(DDSI)=DA(DDSI),DDSDA=DDSDA_DA(DDSI)_","
                     31:        . K DDSI
                     32:        . S DDSSTK=1
                     33:        . D PROC^DDS
                     34:        D LST(.DA,.DDSDL,DDP,DDSDA,DDSFLD)
                     35:        D UDA(.DA,.DDSDL)
                     36:        Q
                     37:        ;
                     38: LST(DA,DDSDL,DDP,DDSDA,DDSFLD) ;Save last edited subrecord
                     39:        ;In:  DA array, DDSDL      at subfile level
                     40:        ;     DDP, DDSDA, DDSFLD   at file level
                     41:        N DDSDIE,Y
                     42:        S DDSDIE=U_$P(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"M"),U,2)
                     43:        I $D(@(DDSDIE_"+$G(DA),0)"))[0 D
                     44:        . S DA=$S($D(@(DDSDIE_"0)"))#2:$P(^(0),U,3),1:$O(^(0)))
                     45:        . I DA>0 D
                     46:        .. N C
                     47:        .. S Y=$P(@(DDSDIE_DA_",0)"),U)
                     48:        .. S C=$P(^DD(+$P(^DD(DDP,DDSFLD,0),U,2),.01,0),U,2)
                     49:        .. D Y^DIQ
                     50:        . E  S (DA,Y)=""
                     51:        E  S (DA,Y)=""
                     52:        I DA>0,$D(DUZ)#2 S ^DISV(DUZ,$E(DDSDIE,1,28))=$E(DDSDIE,29,999)_DA
                     53:        ;
                     54:        S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=Y,^("D")=DA,DDACT="N"
                     55:        Q
                     56:        ;
                     57: SEL    ;Issue the read at the Select mult prompt
                     58:        S DIR(0)="PO"_DDSGL_":QEMZ"_$E("L",'$D(DDSTP)&'$P($G(DDSO(4)),U,5))
                     59:        S:$D(@(DDSGL_"0)"))[0 @(DDSGL_"0)")=U_$P(^DD(DDP,+DDSFLD,0),U,2)_U_U
                     60:        D DDA(0,.DA,.DDSDL),^DIR,UDA(.DA,.DDSDL) K DIR,DUOUT,DIRUT,DIROUT
                     61:        Q:DDACT'="N"
                     62:        ;
                     63:        I DIR0N S (X,Y)=DDSOLD Q
                     64:        I $P(Y,U,3)=1 S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=+Y_","_DDSDA_DDSGL
                     65:        E  S DIR0N=1
                     66:        S Y=$P(Y,U)
                     67:        S:X="" Y=""
                     68:        Q
                     69:        ;
                     70: DDA(Y,DA,DL)   ;Push Y onto DA array
                     71:        N I
                     72:        F I=DL:-1:1 S DA(I+1)=DA(I)
                     73:        S DA(1)=DA,DL=DL+1
                     74:        S (DA,@("D"_DL))=$S(+$P($G(Y),"E"):+$P(Y,"E"),1:0)
                     75:        Q
                     76:        ;
                     77: UDA(DA,DL)     ;Pop DA array
                     78:        N I
                     79:        S DA=DA(1)
                     80:        F I=2:1:DL S DA(I-1)=DA(I)
                     81:        K DA(DL),@("D"_DL)
                     82:        S DL=DL-1
                     83:        Q
                     84: NP(Y)  ;Returns: Next page
                     85:        ;         (Y=1 if found, 0 if not found)
                     86:        N P,P1
                     87:        S Y=0,P1=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,4)
                     88:        I P1]"" D
                     89:        . S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
                     90:        . I P,P'=DDSPG,$D(^DIST(.403,+DDS,40,P,0))#2 S Y=1
                     91:        Q $S(Y=1:P,1:DDSPG)
                     92: PP(Y)  ;
                     93:        N P,P1
                     94:        S Y=0,P1=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,5)
                     95:        I P1]"" D
                     96:        . S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
                     97:        . I P,P'=DDSPG,$D(^DIST(.403,+DDS,40,P,0))#2 S Y=1
                     98:        Q $S(Y=1:P,1:DDSPG)
                     99: NB(Y)  ;
                    100:        N B,BO,X
                    101:        S (B,Y)=0,BO=$P($G(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,0)),U,2)
                    102:        I BO F  D  Q:B=DDSBK!Y
                    103:        . S BO=$O(^DIST(.403,+DDS,40,DDSPG,40,"AC",BO)) S:'BO BO=$O(^("")) S B=$O(^(BO,""))
                    104:        . S X=$G(@DDSREFS@(DDSPG,B))
                    105:        . I $P(X,U)]"",$P(X,U,5)'="h",$P(X,U,9),B'=DDSBK S Y=1
                    106:        Q B