DIFGG4 ;SFISC/XAK,EDE(OHPRD)-FILEGRAM SUBFILES ;6/10/93 1:41 PM
;;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.
;
SUBFILE ; DO ONE SUBFILE
F DIFG(DILL,"FE")=0:0 S DIFG(DILL,"FE")=$O(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_")")) Q:DIFG(DILL,"FE")'=+DIFG(DILL,"FE") D SUBENTRY
Q
;
SUBENTRY ; DO ONE SUBFILE ENTRY
D DIS Q:'$T
D DR S DR(DIFG(DILL,"FILE"))=.01
S DIFG(DILL,"MUL")=1
D LOOKUP^DIFGGU
I $D(DIFGGUQ) K DIFGGUQ,DIFG(DILL,"MUL") Q
D DR,DRS
D RECURSEM
S V="^" D INCSET^DIFGGU
K DIFG(DILL,"MUL"),DA,DR
Q
;
DR ; CREATE DR-STRINGS
K DR S I=0
F %=DIFG(DILL,"FILE"):0 Q:'$D(^DD(%,0,"UP")) S X=^("UP"),Y=$O(^DD(X,"SB",%,0)),DR(X)=Y,DA(%)=DIFG(DILL-I,"FE"),%=X,I=I+1
S DA=DIFG(DILL-I,"FE"),DIC=DIFG(DILL-I,"FILE"),DR=DR(%) K DR(%)
Q
;
DRS ; PROCESS ALL DR STRINGS FOR FILE
S DR(DIFG(DILL,"FILE"))="",DITAB=DITAB+2
I $P(^DIPT(DIFGT,1,DIFGI,0),U,8) F DIFG2=.001:0 S %=DIFG(DILL,"FILE"),DIFG2=$O(^DD(%,DIFG2)) Q:DIFG2'>0 D DRA
F DIFG2=0:0 S DIFG2=$O(^DIPT(DIFGT,1,DIFGI,"F",DIFG2)) Q:DIFG2'=+DIFG2 I $D(^(DIFG2,0)) S DR(DIFG(DILL,"FILE"))=DR(DIFG(DILL,"FILE"))_^(0)_";" I $L(DR(DIFG(DILL,"FILE")))>200 D EN^DIFGG2 S DR(DIFG(DILL,"FILE"))=""
D EN^DIFGG2:DR(DIFG(DILL,"FILE"))]""
S DITAB=DITAB-2
Q
;
DRA ;Process all subfields
S %1=$P(^(0),U,0) I $S('%1:%1'["C",1:$P(^DD(+%1,.01,0),U,2)["W") S DR(%)=DR(%)_DIFG2_";" I $L(DR(%))>200 D EN^DIFGG2 S %=DIFG(DILL,"FILE"),DR(%)=""
Q
;
DIS ; SCREEN THIS ENTRY
F %=1:1:DILL S @("D"_(%-1))=DIFG(%,"FE")
I $D(DIFG(DIFG(DILL,"FILE"),"S"))#2 X DIFG(DIFG(DILL,"FILE"),"S") Q
I 1 Q
;
RECURSEM ; RECURSION FOR DEEPER SUBFILE SHIFTS
S DITAB=DITAB+2
D NEXTLVL^DIFGG
S DITAB=DITAB-2
Q
;
;
DIFGG3 ; FILEGRAM NAVIGATION
; SEE DIFGG3^DIFGGDOC
;
FILE ; PROCESS ONE FILE
F DIFG(DILL,"FE")=0:0 D FILE2 Q:DIFG(DILL,"FE")="" D ENTRY
K I,S,V,X
Q
;
FILE2 ;
S X=$O(^DD(DIFG(DILL,"FILE"),0,"IX",DIFG(DILL,"XREF"),0))
Q:'X
S Y=$O(^DD(DIFG(DILL,"FILE"),0,"IX",DIFG(DILL,"XREF"),X,0))
Q:'Y
I $P(^DD(X,Y,0),U,2)["V" S DIFG(DILL,"FSV")=""""_DIFG(DILL-1,"FE")_";"_$P(^DIC(DIFG(DILL-1,"FILE"),0,"GL"),U,2)_"""" I 1
E S DIFG(DILL,"FSV")=DIFG(DILL-1,"FE")
S DIFG(DILL,"FE")=$O(@(DIFG(DILL,"FGBL")_""""_DIFG(DILL,"XREF")_""","_DIFG(DILL,"FSV")_","_DIFG(DILL,"FE")_")"))
Q
;
ENTRY ; PROCESS ONE FILE ENTRY
S DIFG(DILL,"NAV")=1
D LOOKUP^DIFGGU
K DIFG(DILL,"NAV")
I $D(DIFGGUQ) K DIFGGUQ Q
S DITAB=DITAB+2
D ^DIFGG2
D RECURSEF
S DITAB=2*(DILL-1)
S V=":" D INCSET^DIFGGU
Q
;
RECURSEF ; RECURSION FOR DEEPER FILE SHIFTS
D NEXTLVL^DIFGG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFGG4 2845 printed Oct 16, 2024@18:48:22 Page 2
DIFGG4 ;SFISC/XAK,EDE(OHPRD)-FILEGRAM SUBFILES ;6/10/93 1:41 PM
+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 ;
SUBFILE ; DO ONE SUBFILE
+1 FOR DIFG(DILL,"FE")=0:0
SET DIFG(DILL,"FE")=$ORDER(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_")"))
if DIFG(DILL,"FE")'=+DIFG(DILL,"FE")
QUIT
DO SUBENTRY
+2 QUIT
+3 ;
SUBENTRY ; DO ONE SUBFILE ENTRY
+1 DO DIS
if '$TEST
QUIT
+2 DO DR
SET DR(DIFG(DILL,"FILE"))=.01
+3 SET DIFG(DILL,"MUL")=1
+4 DO LOOKUP^DIFGGU
+5 IF $DATA(DIFGGUQ)
KILL DIFGGUQ,DIFG(DILL,"MUL")
QUIT
+6 DO DR
DO DRS
+7 DO RECURSEM
+8 SET V="^"
DO INCSET^DIFGGU
+9 KILL DIFG(DILL,"MUL"),DA,DR
+10 QUIT
+11 ;
DR ; CREATE DR-STRINGS
+1 KILL DR
SET I=0
+2 FOR %=DIFG(DILL,"FILE"):0
if '$DATA(^DD(%,0,"UP"))
QUIT
SET X=^("UP")
SET Y=$ORDER(^DD(X,"SB",%,0))
SET DR(X)=Y
SET DA(%)=DIFG(DILL-I,"FE")
SET %=X
SET I=I+1
+3 SET DA=DIFG(DILL-I,"FE")
SET DIC=DIFG(DILL-I,"FILE")
SET DR=DR(%)
KILL DR(%)
+4 QUIT
+5 ;
DRS ; PROCESS ALL DR STRINGS FOR FILE
+1 SET DR(DIFG(DILL,"FILE"))=""
SET DITAB=DITAB+2
+2 IF $PIECE(^DIPT(DIFGT,1,DIFGI,0),U,8)
FOR DIFG2=.001:0
SET %=DIFG(DILL,"FILE")
SET DIFG2=$ORDER(^DD(%,DIFG2))
if DIFG2'>0
QUIT
DO DRA
+3 FOR DIFG2=0:0
SET DIFG2=$ORDER(^DIPT(DIFGT,1,DIFGI,"F",DIFG2))
if DIFG2'=+DIFG2
QUIT
IF $DATA(^(DIFG2,0))
SET DR(DIFG(DILL,"FILE"))=DR(DIFG(DILL,"FILE"))_^(0)_";"
IF $LENGTH(DR(DIFG(DILL,"FILE")))>200
DO EN^DIFGG2
SET DR(DIFG(DILL,"FILE"))=""
+4 if DR(DIFG(DILL,"FILE"))]""
DO EN^DIFGG2
+5 SET DITAB=DITAB-2
+6 QUIT
+7 ;
DRA ;Process all subfields
+1 SET %1=$PIECE(^(0),U,0)
IF $SELECT('%1:%1'["C",1:$PIECE(^DD(+%1,.01,0),U,2)["W")
SET DR(%)=DR(%)_DIFG2_";"
IF $LENGTH(DR(%))>200
DO EN^DIFGG2
SET %=DIFG(DILL,"FILE")
SET DR(%)=""
+2 QUIT
+3 ;
DIS ; SCREEN THIS ENTRY
+1 FOR %=1:1:DILL
SET @("D"_(%-1))=DIFG(%,"FE")
+2 IF $DATA(DIFG(DIFG(DILL,"FILE"),"S"))#2
XECUTE DIFG(DIFG(DILL,"FILE"),"S")
QUIT
+3 IF 1
QUIT
+4 ;
RECURSEM ; RECURSION FOR DEEPER SUBFILE SHIFTS
+1 SET DITAB=DITAB+2
+2 DO NEXTLVL^DIFGG
+3 SET DITAB=DITAB-2
+4 QUIT
+5 ;
+6 ;
DIFGG3 ; FILEGRAM NAVIGATION
+1 ; SEE DIFGG3^DIFGGDOC
+2 ;
FILE ; PROCESS ONE FILE
+1 FOR DIFG(DILL,"FE")=0:0
DO FILE2
if DIFG(DILL,"FE")=""
QUIT
DO ENTRY
+2 KILL I,S,V,X
+3 QUIT
+4 ;
FILE2 ;
+1 SET X=$ORDER(^DD(DIFG(DILL,"FILE"),0,"IX",DIFG(DILL,"XREF"),0))
+2 if 'X
QUIT
+3 SET Y=$ORDER(^DD(DIFG(DILL,"FILE"),0,"IX",DIFG(DILL,"XREF"),X,0))
+4 if 'Y
QUIT
+5 IF $PIECE(^DD(X,Y,0),U,2)["V"
SET DIFG(DILL,"FSV")=""""_DIFG(DILL-1,"FE")_";"_$PIECE(^DIC(DIFG(DILL-1,"FILE"),0,"GL"),U,2)_""""
IF 1
+6 IF '$TEST
SET DIFG(DILL,"FSV")=DIFG(DILL-1,"FE")
+7 SET DIFG(DILL,"FE")=$ORDER(@(DIFG(DILL,"FGBL")_""""_DIFG(DILL,"XREF")_""","_DIFG(DILL,"FSV")_","_DIFG(DILL,"FE")_")"))
+8 QUIT
+9 ;
ENTRY ; PROCESS ONE FILE ENTRY
+1 SET DIFG(DILL,"NAV")=1
+2 DO LOOKUP^DIFGGU
+3 KILL DIFG(DILL,"NAV")
+4 IF $DATA(DIFGGUQ)
KILL DIFGGUQ
QUIT
+5 SET DITAB=DITAB+2
+6 DO ^DIFGG2
+7 DO RECURSEF
+8 SET DITAB=2*(DILL-1)
+9 SET V=":"
DO INCSET^DIFGGU
+10 QUIT
+11 ;
RECURSEF ; RECURSION FOR DEEPER FILE SHIFTS
+1 DO NEXTLVL^DIFGG
+2 QUIT
