- DITMU2 ;SFISC/EDE(OHPRD)-RETURN SUBFILE GLOBAL REFERENCE ;2015-01-03 10:14 AM
- ;;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.
- ;
- ; Given a subfile number and global reference form, this routine
- ; will return the global reference for a subfile in the form
- ; specified.
- ;
- ; FORM is optional but if passed should equal 1 or 2. If FORM is
- ; not passed the default form will be 1.
- ;
- ; FORM = 1 will be in the form ^GBL(DA(2),11,DA(1),11,DA,
- ; FORM = 2 will be in the form ^GBL(D0,11,D1,11,D2,
- ;
- ; Formal list:
- ;
- ; 1) SUBFILE = subfile number (call by value)
- ; 2) GBL = global reference (call by reference)
- ; 3) FORM = global reference form (call by value)
- ;
- ; *** NO ERROR CHECKING DONE ***
- ;
- EN(SUBFILE,GBL,FORM) ;
- START ;
- NEW FIELD,I,LVL,NODE,PARENT
- S GBL="",LVL=1
- D BACKUP
- S GBL=^DIC(PARENT,0,"GL")
- I $G(FORM)=2 D S GBL=GBL_"D"_(I+1)_"," I 1
- . F I=0:1 S GBL=GBL_"D"_I_","_NODE(99-LVL)_",",LVL=LVL-1 Q:LVL=0
- . Q
- E D S GBL=GBL_"DA,"
- . F LVL=LVL:-1:0 Q:LVL=0 S GBL=GBL_"DA("_LVL_"),"_NODE(99-LVL)_","
- . Q
- Q
- ;
- BACKUP ; BACKUP TREE (CALLED RECURSIVELY)
- S PARENT=^DD(SUBFILE,0,"UP")
- S FIELD=$O(^DD(PARENT,"SB",SUBFILE,""))
- S NODE(99-LVL)=$P($P(^DD(PARENT,FIELD,0),"^",4),";",1) S:NODE(99-LVL)'=+NODE(99-LVL) NODE(99-LVL)=""""_NODE(99-LVL)_""""
- I $D(^DD(PARENT,0,"UP")) S SUBFILE=PARENT,LVL=LVL+1 D BACKUP ; Recurse
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDITMU2 1663 printed Mar 13, 2025@21:59:17 Page 2
- DITMU2 ;SFISC/EDE(OHPRD)-RETURN SUBFILE GLOBAL REFERENCE ;2015-01-03 10:14 AM
- +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 ;
- +7 ; Given a subfile number and global reference form, this routine
- +8 ; will return the global reference for a subfile in the form
- +9 ; specified.
- +10 ;
- +11 ; FORM is optional but if passed should equal 1 or 2. If FORM is
- +12 ; not passed the default form will be 1.
- +13 ;
- +14 ; FORM = 1 will be in the form ^GBL(DA(2),11,DA(1),11,DA,
- +15 ; FORM = 2 will be in the form ^GBL(D0,11,D1,11,D2,
- +16 ;
- +17 ; Formal list:
- +18 ;
- +19 ; 1) SUBFILE = subfile number (call by value)
- +20 ; 2) GBL = global reference (call by reference)
- +21 ; 3) FORM = global reference form (call by value)
- +22 ;
- +23 ; *** NO ERROR CHECKING DONE ***
- +24 ;
- EN(SUBFILE,GBL,FORM) ;
- START ;
- +1 NEW FIELD,I,LVL,NODE,PARENT
- +2 SET GBL=""
- SET LVL=1
- +3 DO BACKUP
- +4 SET GBL=^DIC(PARENT,0,"GL")
- +5 IF $GET(FORM)=2
- Begin DoDot:1
- +6 FOR I=0:1
- SET GBL=GBL_"D"_I_","_NODE(99-LVL)_","
- SET LVL=LVL-1
- if LVL=0
- QUIT
- +7 QUIT
- End DoDot:1
- SET GBL=GBL_"D"_(I+1)_","
- IF 1
- +8 IF '$TEST
- Begin DoDot:1
- +9 FOR LVL=LVL:-1:0
- if LVL=0
- QUIT
- SET GBL=GBL_"DA("_LVL_"),"_NODE(99-LVL)_","
- +10 QUIT
- End DoDot:1
- SET GBL=GBL_"DA,"
- +11 QUIT
- +12 ;
- BACKUP ; BACKUP TREE (CALLED RECURSIVELY)
- +1 SET PARENT=^DD(SUBFILE,0,"UP")
- +2 SET FIELD=$ORDER(^DD(PARENT,"SB",SUBFILE,""))
- +3 SET NODE(99-LVL)=$PIECE($PIECE(^DD(PARENT,FIELD,0),"^",4),";",1)
- if NODE(99-LVL)'=+NODE(99-LVL)
- SET NODE(99-LVL)=""""_NODE(99-LVL)_""""
- +4 ; Recurse
- IF $DATA(^DD(PARENT,0,"UP"))
- SET SUBFILE=PARENT
- SET LVL=LVL+1
- DO BACKUP
- +5 QUIT
