DDGFASUB ;SFISC/MKO-MANAGE "ASUB" ARRAY ;12:08 PM 14 Aug 2002
;;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.
;
ALL ;Get subpages into @DDGFREF@("ASUB")
N P,B S P=0
F S P=$O(^DIST(.403,+DDGFFM,40,P)) Q:'P D:$P($G(^(P,1)),U,2)]"" ADD(P)
Q
;
ADD(P) ;
;Setup @DDGFREF@("ASUB",pg,bk,ddo)=subpage P
N MP,MB,MF,X
S MF=$$UC($P(^DIST(.403,+DDGFFM,40,P,1),U,2)) Q:MF=""
S MP=$P(MF,",",3),MB=$P(MF,",",2),MF=$P(MF,",")
;
S MP=$O(^DIST(.403,+DDGFFM,40,$S(MP=+$P(MP,"E"):"B",1:"C"),MP,""))
Q:MP=""
;
I MB=+$P(MB,"E") D
. S MB=$O(^DIST(.403,+DDGFFM,40,MP,40,"AC",MB,""))
E D
. S MB=$O(^DIST(.404,"B",$$UC(MB),"")) Q:MB=""
. S MB=$O(^DIST(.403,+DDGFFM,40,MP,40,"B",MB,""))
Q:MB=""
;
S X=$S(MF=+$P(MF,"E"):"B",$D(^DIST(.404,MB,40,"D",MF)):"D",1:"C")
S MF=$O(^DIST(.404,MB,40,X,MF,"")) Q:MF=""
S @DDGFREF@("ASUB",MP,MB,MF)=P,@DDGFREF@("ASUB","B",P,MP,MB,MF)=""
Q
;
DEL(P) ;
;Delete subpage DDGFPG from @DDGFREF@("ASUB")
Q:'$D(@DDGFREF@("ASUB","B",P))
;
N MP,MB,MF
S MP="" F S MP=$O(@DDGFREF@("ASUB","B",P,MP)) Q:MP="" D
. S MB="" F S MB=$O(@DDGFREF@("ASUB","B",P,MP,MB)) Q:MB="" D
.. S MF="" F S MF=$O(@DDGFREF@("ASUB","B",P,MP,MB,MF)) Q:MF="" D
... K @DDGFREF@("ASUB","B",P,MP,MB,MF),@DDGFREF@("ASUB",MP,MB,MF)
Q
;
EDIT(P) ;
;Edit "ASUB" to reflect new parent page
D DEL(P),ADD(P)
Q
UC(X) ;
Q $$UP^DILIBF(X) ;**
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDGFASUB 1650 printed Dec 13, 2024@02:42:17 Page 2
DDGFASUB ;SFISC/MKO-MANAGE "ASUB" ARRAY ;12:08 PM 14 Aug 2002
+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 ;
ALL ;Get subpages into @DDGFREF@("ASUB")
+1 NEW P,B
SET P=0
+2 FOR
SET P=$ORDER(^DIST(.403,+DDGFFM,40,P))
if 'P
QUIT
if $PIECE($GET(^(P,1)),U,2)]""
DO ADD(P)
+3 QUIT
+4 ;
ADD(P) ;
+1 ;Setup @DDGFREF@("ASUB",pg,bk,ddo)=subpage P
+2 NEW MP,MB,MF,X
+3 SET MF=$$UC($PIECE(^DIST(.403,+DDGFFM,40,P,1),U,2))
if MF=""
QUIT
+4 SET MP=$PIECE(MF,",",3)
SET MB=$PIECE(MF,",",2)
SET MF=$PIECE(MF,",")
+5 ;
+6 SET MP=$ORDER(^DIST(.403,+DDGFFM,40,$SELECT(MP=+$PIECE(MP,"E"):"B",1:"C"),MP,""))
+7 if MP=""
QUIT
+8 ;
+9 IF MB=+$PIECE(MB,"E")
Begin DoDot:1
+10 SET MB=$ORDER(^DIST(.403,+DDGFFM,40,MP,40,"AC",MB,""))
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET MB=$ORDER(^DIST(.404,"B",$$UC(MB),""))
if MB=""
QUIT
+13 SET MB=$ORDER(^DIST(.403,+DDGFFM,40,MP,40,"B",MB,""))
End DoDot:1
+14 if MB=""
QUIT
+15 ;
+16 SET X=$SELECT(MF=+$PIECE(MF,"E"):"B",$DATA(^DIST(.404,MB,40,"D",MF)):"D",1:"C")
+17 SET MF=$ORDER(^DIST(.404,MB,40,X,MF,""))
if MF=""
QUIT
+18 SET @DDGFREF@("ASUB",MP,MB,MF)=P
SET @DDGFREF@("ASUB","B",P,MP,MB,MF)=""
+19 QUIT
+20 ;
DEL(P) ;
+1 ;Delete subpage DDGFPG from @DDGFREF@("ASUB")
+2 if '$DATA(@DDGFREF@("ASUB","B",P))
QUIT
+3 ;
+4 NEW MP,MB,MF
+5 SET MP=""
FOR
SET MP=$ORDER(@DDGFREF@("ASUB","B",P,MP))
if MP=""
QUIT
Begin DoDot:1
+6 SET MB=""
FOR
SET MB=$ORDER(@DDGFREF@("ASUB","B",P,MP,MB))
if MB=""
QUIT
Begin DoDot:2
+7 SET MF=""
FOR
SET MF=$ORDER(@DDGFREF@("ASUB","B",P,MP,MB,MF))
if MF=""
QUIT
Begin DoDot:3
+8 KILL @DDGFREF@("ASUB","B",P,MP,MB,MF),@DDGFREF@("ASUB",MP,MB,MF)
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
EDIT(P) ;
+1 ;Edit "ASUB" to reflect new parent page
+2 DO DEL(P)
DO ADD(P)
+3 QUIT
UC(X) ;
+1 ;**
QUIT $$UP^DILIBF(X)
