Return to DIFGB.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DIFGB.m, revision 1.1.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