DIFGB.m

DIFGB ;SFISC/XAK-STORE FILEGRAM TEMPLATE ;5/23/96  11:16

 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42

 ;;Per VA Directive 6402, this routine should not be modified.

 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.

 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.

 ;;Licensed under the terms of the Apache License, Version 2.0.

 ;

PUT ;

 W !,"STORE ",$S($D(DIAR):"ARCHIVE",$D(DIAX):"EXTRACT",1:"FILEGRAM")_" LOGIC IN TEMPLATE: "

 R X:DTIME S:'$T DTOUT=1,X="" G Q:U[X

 S DIC="^DIPT(",D="F"_DK

 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)

 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

 S S=$O(^DIPT(+Y,0))]""

 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

 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

 I '$D(DIAX) S ^DIPT("FG",$P(Y,U,2),+Y)="",$P(^DIPT(+Y,0),U,8)=1

 E  S $P(^DIPT(+Y,0),U,8,9)=2_U_DIAXFNO

 S Y=+Y,%X=""

 F %=1:1 S %X=$O(^UTILITY("DIFG",$J,%X)) Q:%X=""  S ^DIPT(Y,1,%,0)=^(%X) D FLD

 S:%-1 ^DIPT(Y,1,0)="^.41^"_(%-1)_U_(%-1)

 I '$D(DIAX) S ^DIPT(Y,"F",2)="S DIFGT="""_$P(^DIPT(+Y,0),U)_""",DIFGBFN="_DK_" D FG^DIFGB;X"

Q K ^UTILITY("DIFG",$J),DIFG Q

 ;

PURGE L +^DIPT(+Y)

 S %Y=0 F %X=0:0 S %Y=$O(^DIPT(+Y,%Y)) Q:%Y=""  K:%Y'="%D" ^DIPT(+Y,%Y)

 L -^DIPT(+Y)

 Q

 ;

W S %=$P(^DIPT(+Y,0),U,6) F X=1:1:$L(%) I DUZ(0)[$E(%,X) Q

 Q

 ;

FLD S %Y=""

 F S=1:1 S %Y=$O(^UTILITY("DIFG",$J,%X,%Y)) Q:%Y=""  S ^DIPT(Y,1,%,"F",S,0)=^(%Y)

 S:S-1 ^DIPT(Y,1,%,"F",0)="^.411^"_(S-1)_U_(S-1) Q

 ;

TEM ;

 S X=$E(X,2,99),DIC="^DIPT(",DIC(0)="SQEM",D="FG" I X["?"!($D(DIAX)) S D="F"_DK

 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:"")

 D IX^DIC S X="" Q:Y<0

EN ;

 K DIR S DA=+Y

 S DIR(0)="Y",DIR("A")="WANT TO EDIT '"_$P(Y,U,2)_"' TEMPLATE"

 D ^DIR K DIR S:'Y!$D(DTOUT) X=U Q:'Y  D DIE I '$D(DA) S DC=0 Q

 S DC(1)=0,DC(0)=DA K DA D GET

 S DJ=0,X="" ;D EN^DIFGA,PUT:X'=U

 Q

GET S DC(1)=$O(^DIPT(DC(0),1,+DC(1))),DC=0 Q:+DC(1)'=DC(1)

 S %=^(DC(1),0),X=+% Q:'X  S DC=1

 I DL>1,$P(%,U,2)'>DL F J=$P(%,U,2):1:DL S DC=DC+1,DC(DC)=""

 I $D(DIAX),$P(%,U,4)>2 S $P(DC(1),U,3)=$O(^DD(+$P(%,U,9),0,"NM",""))

 I $P(%,U,5)]"" S DC=DC+1,DC(DC)=$P(%,U,5)

 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

 S DC=$S($D(DC(2)):2,1:0)

 Q

DIE N DL,DK,DI

 S DIE="^DIPT(",DR=".01;3;6" D ^DIE K DIE,DR S X=""

 Q

FG ;Entry from Print template

 K ^UTILITY($J,"W")

 S DIFG("FE")=D0,DIFG("FUNC")="L",DIFG("FGR")="^UTILITY(""DIFG"",$J,"

 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

 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

 I $G(DIARP)]"",+DIARP'=+DIFGT S DIFGT=DIARP,^DIPT(DIARP,"F",2)="S DIFGT="_DIARP_" D FG^DIFGB;X"

 N DI,D0 D START^DIFGG

 I $D(DIARD) S DIARD=DIARD+1 W:(DIARD#50=0) !,DIARD," RECORDS PROCESSED"

 I $G(DIAR)=4 S ^DIAR(1.11,DIARC,"D",0)="^1.113^"_DILC_U_DILC Q

 S DIWL=1,DIWR=IOM-1,DIWF="NW"

 F D1=0:0 S D1=$O(^UTILITY("DIFG",$J,D1)) Q:D1'>0  S X=^(D1,0) D ^DIWP Q:'DN

 D:DN ^DIWW G Q

WR F D1=0:0 S D1=$O(^DIAR(1.11,DIARC,"D",D1)) Q:D1'>0  S X=^(D1,0) W X

 G Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DIFGB   3604     printed  Feb 19, 2025@00:14:01                                                                                                                                                                                                       Page 2

DIFGB     ;SFISC/XAK-STORE FILEGRAM TEMPLATE ;5/23/96  11:16

 +1       ;;22.2;VA FileMan;;Jan 05, 2016;Build 42

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.

 +4       ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.

 +5       ;;Licensed under the terms of the Apache License, Version 2.0.

 +6       ;

PUT       ;

 +1        WRITE !,"STORE ",$SELECT($DATA(DIAR):"ARCHIVE",$DATA(DIAX):"EXTRACT",1:"FILEGRAM")_" LOGIC IN TEMPLATE: "

 +2        READ X:DTIME

           if '$TEST

               SET DTOUT=1

               SET X=""

           if U[X

               GOTO Q

 +3        SET DIC="^DIPT("

           SET D="F"_DK

 +4        SET DIC("S")="S %=^(0) I $P(%,U,8)="_$SELECT($DATA(DIAX):2,1:1)_",$P(%,U,4)=DK!'$L($P(%,U,4))"_$PIECE(" F DW=1:1:$L($P(%,U,3)) I DUZ(0)[$E($P(%,U,3),DW) Q",U,DUZ(0)'="@"&L)

 +5        SET DIC(0)="ELZSQI"

           SET DIC("S")="I Y'<1 "_DIC("S")

           SET Y=-1

           SET DLAYGO=0

           if X]""

               DO IX^DIC

           KILL DIC,DLAYGO

           if Y<0

               if X'[U

                   GOTO PUT

               GOTO Q

 +6        SET S=$ORDER(^DIPT(+Y,0))]""

 +7        IF S

               WRITE $CHAR(7),!,"TEMPLATE ALREADY STORED THERE...."

               if DUZ(0)'="@"

                   DO W

               if '$TEST

                   GOTO PUT

               WRITE " OK TO REPLACE"

               SET %=0

               DO YN^DICN

               WRITE !

               if %-1

                   GOTO PUT

               DO PURGE

 +8        SET ^DIPT(+Y,0)=$PIECE(Y,U,2)_U_DT_U_DUZ(0)_U_DK_U_DUZ_U_DUZ(0)_U_DT

           SET ^DIPT("F"_DK,$PIECE(Y,U,2),+Y)=1

 +9        IF '$DATA(DIAX)

               SET ^DIPT("FG",$PIECE(Y,U,2),+Y)=""

               SET $PIECE(^DIPT(+Y,0),U,8)=1

 +10      IF '$TEST

               SET $PIECE(^DIPT(+Y,0),U,8,9)=2_U_DIAXFNO

 +11       SET Y=+Y

           SET %X=""

 +12       FOR %=1:1

               SET %X=$ORDER(^UTILITY("DIFG",$JOB,%X))

               if %X=""

                   QUIT 

               SET ^DIPT(Y,1,%,0)=^(%X)

               DO FLD

 +13       if %-1

               SET ^DIPT(Y,1,0)="^.41^"_(%-1)_U_(%-1)

 +14       IF '$DATA(DIAX)

               SET ^DIPT(Y,"F",2)="S DIFGT="""_$PIECE(^DIPT(+Y,0),U)_""",DIFGBFN="_DK_" D FG^DIFGB;X"

Q          KILL ^UTILITY("DIFG",$JOB),DIFG

           QUIT 

 +1       ;

PURGE      LOCK +^DIPT(+Y)

 +1        SET %Y=0

           FOR %X=0:0

               SET %Y=$ORDER(^DIPT(+Y,%Y))

               if %Y=""

                   QUIT 

               if %Y'="%D"

                   KILL ^DIPT(+Y,%Y)

 +2        LOCK -^DIPT(+Y)

 +3        QUIT 

 +4       ;

W          SET %=$PIECE(^DIPT(+Y,0),U,6)

           FOR X=1:1:$LENGTH(%)

               IF DUZ(0)[$EXTRACT(%,X)

                   QUIT 

 +1        QUIT 

 +2       ;

FLD        SET %Y=""

 +1        FOR S=1:1

               SET %Y=$ORDER(^UTILITY("DIFG",$JOB,%X,%Y))

               if %Y=""

                   QUIT 

               SET ^DIPT(Y,1,%,"F",S,0)=^(%Y)

 +2        if S-1

               SET ^DIPT(Y,1,%,"F",0)="^.411^"_(S-1)_U_(S-1)

           QUIT 

 +3       ;

TEM       ;

 +1        SET X=$EXTRACT(X,2,99)

           SET DIC="^DIPT("

           SET DIC(0)="SQEM"

           SET D="FG"

           IF X["?"!($DATA(DIAX))

               SET D="F"_DK

 +2        SET DIC("S")="I $P(^(0),U,4)="_DK_",$P(^(0),U,8)="_$SELECT($DATA(DIAX):2,1:1)_$SELECT($DATA(DIAX):",$P(^(0),U,9)=DIAXFNO",1:"")

 +3        DO IX^DIC

           SET X=""

           if Y<0

               QUIT 

EN        ;

 +1        KILL DIR

           SET DA=+Y

 +2        SET DIR(0)="Y"

           SET DIR("A")="WANT TO EDIT '"_$PIECE(Y,U,2)_"' TEMPLATE"

 +3        DO ^DIR

           KILL DIR

           if 'Y!$DATA(DTOUT)

               SET X=U

           if 'Y

               QUIT 

           DO DIE

           IF '$DATA(DA)

               SET DC=0

               QUIT 

 +4        SET DC(1)=0

           SET DC(0)=DA

           KILL DA

           DO GET

 +5       ;D EN^DIFGA,PUT:X'=U

           SET DJ=0

           SET X=""

 +6        QUIT 

GET        SET DC(1)=$ORDER(^DIPT(DC(0),1,+DC(1)))

           SET DC=0

           if +DC(1)'=DC(1)

               QUIT 

 +1        SET %=^(DC(1),0)

           SET X=+%

           if 'X

               QUIT 

           SET DC=1

 +2        IF DL>1

               IF $PIECE(%,U,2)'>DL

                   FOR J=$PIECE(%,U,2):1:DL

                       SET DC=DC+1

                       SET DC(DC)=""

 +3        IF $DATA(DIAX)

               IF $PIECE(%,U,4)>2

                   SET $PIECE(DC(1),U,3)=$ORDER(^DD(+$PIECE(%,U,9),0,"NM",""))

 +4        IF $PIECE(%,U,5)]""

               SET DC=DC+1

               SET DC(DC)=$PIECE(%,U,5)

 +5        FOR J=0:0

               SET J=$ORDER(^DIPT(DC(0),1,+DC(1),"F",J))

               if +J'=J

                   QUIT 

               SET %=^(J,0)

               SET DIAXZ=$PIECE(%,U,2,9)

               SET %=+%

               SET %=$SELECT($DATA(^DD(X,%,0)):$PIECE(^(0),U),1:%)

               if '%

                   SET DC=DC+1

                   SET DC(DC)=%_U_DIAXZ

 +6        SET DC=$SELECT($DATA(DC(2)):2,1:0)

 +7        QUIT 

DIE        NEW DL,DK,DI

 +1        SET DIE="^DIPT("

           SET DR=".01;3;6"

           DO ^DIE

           KILL DIE,DR

           SET X=""

 +2        QUIT 

FG        ;Entry from Print template

 +1        KILL ^UTILITY($JOB,"W")

 +2        SET DIFG("FE")=D0

           SET DIFG("FUNC")="L"

           SET DIFG("FGR")="^UTILITY(""DIFG"",$J,"

 +3        IF 'DIFGT

               SET DIC="^DIPT("

               SET D="FG"

               SET DIC("S")="I $P(^(0),U,4)="_DIFGBFN

               SET DIC(0)="O"

               SET X=DIFGT

               KILL DIFGBFN

               DO IX^DIC

               if +Y

                   SET DIFGT=+Y

               IF Y'>0

                   KILL DIFG,DIFGT

                   GOTO Q

 +4        IF $GET(DIAR)=4

               SET DIFG("FGR")="^DIAR(1.11,DIARC,""D"","

               IF DIARF=DIARF2

                   IF $DATA(^DIC(+DIARF,0,"GL"))

                       SET D1=^("GL")

                       SET @(D1_"D0,-9)")=DIARC

 +5        IF $GET(DIARP)]""

               IF +DIARP'=+DIFGT

                   SET DIFGT=DIARP

                   SET ^DIPT(DIARP,"F",2)="S DIFGT="_DIARP_" D FG^DIFGB;X"

 +6        NEW DI,D0

           DO START^DIFGG

 +7        IF $DATA(DIARD)

               SET DIARD=DIARD+1

               if (DIARD#50=0)

                   WRITE !,DIARD," RECORDS PROCESSED"

 +8        IF $GET(DIAR)=4

               SET ^DIAR(1.11,DIARC,"D",0)="^1.113^"_DILC_U_DILC

               QUIT 

 +9        SET DIWL=1

           SET DIWR=IOM-1

           SET DIWF="NW"

 +10       FOR D1=0:0

               SET D1=$ORDER(^UTILITY("DIFG",$JOB,D1))

               if D1'>0

                   QUIT 

               SET X=^(D1,0)

               DO ^DIWP

               if 'DN

                   QUIT 

 +11       if DN

               DO ^DIWW

           GOTO Q

WR         FOR D1=0:0

               SET D1=$ORDER(^DIAR(1.11,DIARC,"D",D1))

               if D1'>0

                   QUIT 

               SET X=^(D1,0)

               WRITE X

 +1        GOTO Q