Return to DID.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DID.m, revision 1.1

1.1     ! snw         1: DID    ;SFISC/XAK-LIST DD'S ;10:11 AM  16 Dec 1994
        !             2:        ;;21.0;VA FileMan;;Dec 28, 1994
        !             3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
        !             4:        D KL,L^DICRW1 I $D(DIC) S (DUB,DIB,DFF)=+Y G O:Y'=+DIB(1),SUB
        !             5: KL     K DIS,DIJS,DHIT,DIB,DINM,DIDX,DIGR,DIDH,BY,DICMX,DIOEND,FLDS
        !             6:        K DFF,DIFF,DID,DUB,DHD,DIC,DICS,POP,DA,DR,S,F,J,K,Z,W,X,Y,M,G,N,I
        !             7:        K DIWF,DIPP,DPP,DIMS,DIPQ,DJ,DDL1,DDL2,DDL3,DDLF,DDN1,X1,DDRG,I1 Q
        !             8:        ;
        !             9: SUB    S DIC="^DD("_+Y_"," G O:$O(^DD(+Y,"SB",0))'>0 S DIC(0)="AEQZ",DIC("A")="      Select SUB-FILE: ",DIC("S")="I $P(^(0),U,2)" D ^DIC G KL:$D(DTOUT) I Y>0 S (DFF,Y)=+$P(Y(0),U,2) G SUB
        !            10:        G KL:X[U
        !            11: O      K DIC S:DFF-DUB DIC("S")="I Y-5" S DIC="^DOPT(""DID"",",DIC(0)="AEQ",DIC("B")=1 D ^DIC G KL:Y<0
        !            12: O1     K DIC S DIC="^DD(DFF,"
        !            13:        I +Y=3 S DIS(0)="I $D(^DD(DFF,D0,0))",DIOEND="G L^DIDC",DIOBEG="S L=0 I $D(DQI),DQI,$D(^UTILITY($J,2)) S ^(1.5)=""W $O(^DD(DIB,0,""""NM"""",0))_"""" FILE """""",^(2)=""X ^(1.5) ""_^(2)" D EN^DIP G KL
        !            14:        I +Y=4,'$D(DIFORMAT) D MOD^DID2 G KL:X[U
        !            15:        S L=0,FLDS="",BY="@.001" I +Y=5 S (FR,TO)=.01,DHIT="S F(1)=DUB",DHD="W """" D H1^DIDG",DIOEND="D T^DID" G G
        !            16:        S DHIT="D ^DID1",DHD="W """" D ^DIDH",(FR,TO)="",DIOEND="D END^DID"
        !            17:        I +Y=6 S DHIT="D ^DIDG",DIOEND="D END^DIDG"
        !            18:        I +Y=2 S DHIT="D ^DIDX",DIDX=0,%=2 I '$D(DIFORMAT) D AH^DIDX Q:%<1
        !            19:        I +Y=7 S DHIT="S (X1,X2)=DFF D ^DIDC",DHD="@" S DIOEND="D IOF^DID"
        !            20: G      Q:DIB=0  S DIOEND(1)=DIOEND,DIOEND="D LOOP^DID" D EN1^DIP G KL
        !            21: LOOP   I $D(Y),Y=U Q
        !            22:        X DIOEND(1) I $D(M),M=U Q
        !            23:        I IOST?1"C-".E W $C(7) R X:DTIME I X[U!'$T Q
        !            24:        S DN=1,D0=0,DIB=$O(^DIC(+DIB)) Q:DIB>DIB(1)!(+DIB'=DIB)  S (F(1),DUB,DFF)=DIB,DC="," D ^DIO2 I $D(M),M=U Q
        !            25:        G LOOP
        !            26:        ;
        !            27: END    ;
        !            28:        I $D(^UTILITY($J,"P")) W !!!?6,"FILES POINTED TO",?44,"FIELDS",! D PTR^DIDC
        !            29: D      K ^UTILITY($J,"P") G IOF:DHIT["DIDX"
        !            30: T      ;
        !            31:        S S=0,M=1
        !            32: T1     S S=S+1 D:$Y+3>IOSL HDR^DIDG Q:M=U
        !            33:        W !!,$S(S<4:$P("INPU^PRIN^SOR",U,S)_"T TEMPLATE(S):",1:"FORM(S)/BLOCK(S):")
        !            34:        S DFF="^DI"_$P("E^PT^BT^ST(.403)",U,S),DA=""
        !            35:        F  S DA=$O(@DFF@("F"_F(1),DA)) Q:DA=""  D  Q:M=U
        !            36:        . S DUB=0 F  S DUB=$O(@DFF@("F"_F(1),DA,DUB)) Q:'DUB  D  Q:M=U
        !            37:        .. I $D(@DFF@(DUB,0))#2 S %1=^(0) D TEMPL
        !            38:        K %1 G Q:M=U,T1:S<4
        !            39: IOF    W:IOST'?1"C".E @IOF Q
        !            40:        ;
        !            41: TEMPL  I $Y+3>IOSL D HDR^DIDG Q:M=U
        !            42:        W !,$P(%1,U),?30 G:DFF["DIST" FORM
        !            43:        S W="",Y=$P(%1,U,2) I Y D DD^%DT W Y
        !            44:        W ?50,"USER #"_+$P(%1,U,5),?61 I $D(@(DFF_"(DUB,""ROU"")")) W ^("ROU")_$P("*",U,DFF["DIBT")_" "
        !            45:        I $D(^("H")) S Y=^("H"),%=$L(Y) W:65+%>IOM ! W "   ",?IOM-%-1,$E(Y,1,IOM-4)
        !            46:        G DES:DFF'="^DIBT"
        !            47:        I $D(^("DIPT")) W ?55 S Y=" '"_^("DIPT")_"' Print Template always used" W:$X+$L(Y)>IOM ! W ?IOM-$L(Y)-1,Y
        !            48:        I $D(^(2)) S D0=DUB,DICMX="W !?4,X" X $P(^DD(.401,1620,0),U,5,99)
        !            49:        F Y=1:1 Q:'$D(^DIBT(DUB,"O",Y,0))  W "  " S %=^(0),D=IOM-$L(%)-5 W:$X>D !?$S(D>55:55,1:D) W %
        !            50: DES    N A1,%1,X S A1=$P($G(@(DFF_"(DUB,""%D"",0)")),U,3) F %1=0:0 S %1=$O(@(DFF_"(DUB,""%D"",%1)")) Q:%1'>0  Q:+A1&(%1>A1)  S X=^(%1,0) W !,?5,X
        !            51: Q      W:DFF["DIBT" ! Q
        !            52: DT     G DT^DIO2
        !            53:        ;
        !            54: EN     ;
        !            55:        Q:'$D(DIC)  I 'DIC,$D(@(DIC_"0)")) S DIC=+$P(^(0),U,2)
        !            56:        Q:'DIC!'$D(^DIC(DIC,0,"GL"))  S (DFF,DUB,DIB,DIB(1))=DIC
        !            57:        G O:'$D(DIFORMAT) S Y=DIFORMAT I 'Y S Y=$O(^DOPT("DID","B",Y,0))
        !            58:        Q:Y>7!'Y  G O1
        !            59:        ;
        !            60: FORM   ;
        !            61:        S Y=$P(%1,U,5) I Y D DD^%DT W ?30,Y
        !            62:        W ?50,"USER #"_+$P(%1,U,4)
        !            63:        ;
        !            64:        N B,L,P
        !            65:        S L=1,L(1)=U
        !            66:        S P=0 F  S P=$O(^DIST(.403,DUB,40,P)) Q:'P  D  Q:M=U
        !            67:        . Q:$D(^DIST(.403,DUB,40,P,0))[0  S B=$P(^(0),U,2) D:B BLOCK  Q:M=U
        !            68:        . S B=0 F  S B=$O(^DIST(.403,DUB,40,P,40,B)) Q:'B  D BLOCK  Q:M=U
        !            69:        S %1=0 F  S %1=$O(@DFF@(DUB,15,%1)) Q:'%1  W:$D(^(%1,0))#2 !?5,^(0)
        !            70:        W !
        !            71:        Q
        !            72: BLOCK  ;
        !            73:        N I
        !            74:        F I=1:1:L I L(I)[(U_B_U) G BLOCKQ
        !            75:        S:$L(L)+$L(B)+1>245 L=L+1,L(L)=U S L(L)=L(L)_B_U
        !            76:        Q:$D(^DIST(.404,B,0))[0  S %1=^(0)
        !            77:        ;
        !            78:        I $Y+3>IOSL D HDR^DIDG Q:M=U
        !            79:        W !?2,$P(%1,U) W:$P(%1,U,2)]"" ?32,"DD #"_$P(%1,U,2)
        !            80: BLOCKQ Q
        !            81:        ;
        !            82: FILELST(DIDROOT)       ;
        !            83:        I '$D(DIQUIET) N DIQUIET S DIQUIET=1
        !            84:        I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
        !            85:        N DIDARRAY
        !            86:        D EN4^DIQGDD
        !            87:        M @DIDROOT=DIDARRAY
        !            88:        Q
        !            89:        ;
        !            90: FILE(DIQGR,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR)       ;
        !            91:        I '$D(DIQUIET) N DIQUIET S DIQUIET=1
        !            92:        I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
        !            93:        G EN2^DIQGDD
        !            94:        ;
        !            95: FIELDLST(DIDROOT)      ;
        !            96:        I '$D(DIQUIET) N DIQUIET S DIQUIET=1
        !            97:        I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
        !            98:        N DIDARRAY
        !            99:        D EN5^DIQGDD
        !           100:        M @DIDROOT=DIDARRAY
        !           101:        Q
        !           102:        ;
        !           103: FIELD(DIQGR,DA,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR)   ;
        !           104:        I '$D(DIQUIET) N DIQUIET S DIQUIET=1
        !           105:        I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
        !           106:        G EN1^DIQGDD
        !           107:        ;
        !           108: GET1(DIQGR,DA,DIQGPARM,DR,DIQGETA,DIQGERRA,DIQGIPAR)   ;
        !           109:        I '$D(DIQUIET) N DIQUIET S DIQUIET=1
        !           110:        I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
        !           111:        G EN3^DIQGDD
        !           112:        ;
        !           113: PIECE(DIQGR,DA,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR)   ;CLOSEDREF,PIECE,FLAG,ATTRIBUTE,TARGETARRAY,ERRORARRAY,INTERNAL
        !           114:        ;PROCEDURE CALL AND  * * RETURN RESULTS IN TARGET ARRAY * *
        !           115:        I '$D(DIQUIET) N DIQUIET S DIQUIET=1
        !           116:        I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
        !           117:        G EN6^DIQGDD0