DIFGB ;SFISC/XAK-STORE FILEGRAM TEMPLATE ;5/23/96 11:16
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
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
DIFGB ;SFISC/XAK-STORE FILEGRAM TEMPLATE ;5/23/96 11:16
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
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
