- DDGFASUB ;SFISC/MKO-MANAGE "ASUB" ARRAY ;09:36 AM 29 Mar 1994
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- 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 $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- DDGFASUB ;SFISC/MKO-MANAGE "ASUB" ARRAY ;09:36 AM 29 Mar 1994
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- 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 $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
