Return to DIFGB.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DIFGB.m, revision 1.1

1.1     ! snw         1: DIFGB  ;SFISC/XAK-STORE FILEGRAM TEMPLATE ;10/14/92  8:10 AM
        !             2:        ;;21.0;VA FileMan;;Dec 28, 1994
        !             3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
        !             4: PUT    ;
        !             5:        W !,"STORE ",$S($D(DIAR):"ARCHIVE",$D(DIAX):"EXTRACT",1:"FILEGRAM")_" LOGIC IN TEMPLATE: "
        !             6:        R X:DTIME S:'$T DTOUT=1,X="" G Q:U[X
        !             7:        S DIC="^DIPT(",D="F"_DK
        !             8:        S DIC("S")="S %=^(0) I $P(%,U,8)="_$S($D(DIAX):2,1:1)_",$P(%,U,4)=DK!'$L($P(%,U,4))"_$P(" F DW=1:1:$L($P(%,U,3)) I DUZ(0)[$E($P(%,U,3),DW) Q",U,DUZ(0)'="@"&L)
        !             9:        S DIC(0)="ELZSQI",DIC("S")="I Y'<1 "_DIC("S"),Y=-1,DLAYGO=0 D IX^DIC:X]"" K DIC,DLAYGO G:Y<0 PUT:X'[U,Q
        !            10:        S S=$O(^DIPT(+Y,0))]""
        !            11:        I S W $C(7),!,"TEMPLATE ALREADY STORED THERE...." D W:DUZ(0)'="@" G PUT:'$T W " OK TO REPLACE" S %=0 D YN^DICN W ! G PUT:%-1 D PURGE
        !            12:        S ^DIPT(+Y,0)=$P(Y,U,2)_U_DT_U_DUZ(0)_U_DK_U_DUZ_U_DUZ(0)_U_DT,^DIPT("F"_DK,$P(Y,U,2),+Y)=1
        !            13:        I '$D(DIAX) S ^DIPT("FG",$P(Y,U,2),+Y)="",$P(^DIPT(+Y,0),U,8)=1
        !            14:        E  S ^DIPT("EX",$P(Y,U,2),+Y)="",$P(^DIPT(+Y,0),U,8,9)=2_U_DIAXFNO
        !            15:        S Y=+Y,%X=""
        !            16:        F %=1:1 S %X=$O(^UTILITY("DIFG",$J,%X)) Q:%X=""  S ^DIPT(Y,1,%,0)=^(%X) D FLD
        !            17:        S:%-1 ^DIPT(Y,1,0)="^.41^"_(%-1)_U_(%-1)
        !            18:        I '$D(DIAX) S ^DIPT(Y,"F",2)="S DIFGT="""_$P(^DIPT(+Y,0),U)_""",DIFGBFN="_DK_" D FG^DIFGB;X"
        !            19:        E  S ^DIPT(Y,"F",2)="D ^DIAXU;X"
        !            20: Q      K ^UTILITY("DIFG",$J),DIFG Q
        !            21:        ;
        !            22: PURGE  L +^DIPT(+Y)
        !            23:        S %Y=0 F %X=0:0 S %Y=$O(^DIPT(+Y,%Y)) Q:%Y=""  K:%Y'="%D" ^DIPT(+Y,%Y)
        !            24:        L -^DIPT(+Y)
        !            25:        Q
        !            26:        ;
        !            27: W      S %=$P(^DIPT(+Y,0),U,6) F X=1:1:$L(%) I DUZ(0)[$E(%,X) Q
        !            28:        Q
        !            29:        ;
        !            30: FLD    S %Y=""
        !            31:        F S=1:1 S %Y=$O(^UTILITY("DIFG",$J,%X,%Y)) Q:%Y=""  S ^DIPT(Y,1,%,"F",S,0)=^(%Y)
        !            32:        S:S-1 ^DIPT(Y,1,%,"F",0)="^.411^"_(S-1)_U_(S-1) Q
        !            33:        ;
        !            34: TEM    ;
        !            35:        S X=$E(X,2,99),DIC="^DIPT(",DIC(0)="SQEM",D=$S($D(DIAX):"EX",1:"FG") S:X["?" D="F"_DK
        !            36:        S DIC("S")="I $P(^(0),U,4)="_DK_",$P(^(0),U,8)="_$S($D(DIAX):2,1:1)_$S($D(DIAX):",$P(^(0),U,9)=DIAXFNO",1:"")
        !            37:        D IX^DIC S X="" Q:Y<0
        !            38: EN     ;
        !            39:        K DIR S DA=+Y
        !            40:        S DIR(0)="Y",DIR("A")="WANT TO EDIT '"_$P(Y,U,2)_"' TEMPLATE"
        !            41:        D ^DIR K DIR S:'Y!$D(DTOUT) X=U Q:'Y  D DIE I '$D(DA) S DC=0 Q
        !            42:        S DC(1)=0,DC(0)=DA K DA D GET
        !            43:        S DJ=0,X="" ;D EN^DIFGA,PUT:X'=U
        !            44:        Q
        !            45: GET    S DC(1)=$O(^DIPT(DC(0),1,+DC(1))),DC=0 Q:+DC(1)'=DC(1)
        !            46:        S %=^(DC(1),0),X=+% Q:'X  S DC=1
        !            47:        I DL>1,$P(%,U,2)'>DL F J=$P(%,U,2):1:DL S DC=DC+1,DC(DC)=""
        !            48:        I $D(DIAX),$P(%,U,4)>2 S $P(DC(1),U,3)=$O(^DD(+$P(%,U,9),0,"NM",""))
        !            49:        I $P(%,U,5)]"" S DC=DC+1,DC(DC)=$P(%,U,5)
        !            50:        F J=0:0 S J=$O(^DIPT(DC(0),1,+DC(1),"F",J)) Q:+J'=J  S %=^(J,0),DIAXZ=$P(%,U,2,9),%=+%,%=$S($D(^DD(X,%,0)):$P(^(0),U),1:%) S:'% DC=DC+1,DC(DC)=%_U_DIAXZ
        !            51:        S DC=$S($D(DC(2)):2,1:0)
        !            52:        Q
        !            53: DIE    N DL,DK,DI
        !            54:        S DIE="^DIPT(",DR=".01;3;6" D ^DIE K DIE,DR S X=""
        !            55:        Q
        !            56: FG     ;Entry from Print template
        !            57:        K ^UTILITY($J,"W")
        !            58:        S DIFG("FE")=D0,DIFG("FUNC")="L",DIFG("FGR")="^UTILITY(""DIFG"",$J,"
        !            59:        I 'DIFGT S DIC="^DIPT(",D="FG",DIC("S")="I $P(^(0),U,4)="_DIFGBFN,DIC(0)="O",X=DIFGT K DIFGBFN D IX^DIC S:+Y DIFGT=+Y I Y'>0 K DIFG,DIFGT G Q
        !            60:        I $G(DIAR)=4 S DIFG("FGR")="^DIAR(1.11,DIARC,""D""," I DIARF=DIARF2,$D(^DIC(+DIARF,0,"GL")) S D1=^("GL"),@(D1_"D0,-9)")=DIARC
        !            61:        I $G(DIARP)]"",+DIARP'=+DIFGT S DIFGT=DIARP,^DIPT(DIARP,"F",2)="S DIFGT="_DIARP_" D FG^DIFGB;X"
        !            62:        N DI,D0 D START^DIFGG
        !            63:        I $D(DIARD) S DIARD=DIARD+1 W:(DIARD#50=0) !,DIARD," RECORDS PROCESSED"
        !            64:        I $G(DIAR)=4 S ^DIAR(1.11,DIARC,"D",0)="^1.113^"_DILC_U_DILC Q
        !            65:        S DIWL=1,DIWR=IOM-1,DIWF="NW"
        !            66:        F D1=0:0 S D1=$O(^UTILITY("DIFG",$J,D1)) Q:D1'>0  S X=^(D1,0) D ^DIWP Q:'DN
        !            67:        D:DN ^DIWW G Q
        !            68: WR     F D1=0:0 S D1=$O(^DIAR(1.11,DIARC,"D",D1)) Q:D1'>0  S X=^(D1,0) W X
        !            69:        G Q