DIAXT ;SFISC/DCM-GET EXTRACT TEMPLATE SPECS ;5/13/96 14:01
;;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.
;
EN N DIAXI,DILL,DIAX
S DIAXTTO="^TMP($J,""DIAXTTO"")",DIAXTFR="^TMP($J,""DIAXTFR"")"
K @DIAXTTO,@DIAXTFR
D SPEC
Q
SPEC ;get specs
D TOP,DR
D NEXTLVL
Q
TOP ;get base file specs from extract template
N X
S DIAXI=0
S DIAXI=$O(^DIPT(DIAXT,1,DIAXI)) Q:DIAXI'>0 S X=^(DIAXI,0)
S DILL=$P(X,U,2)
FILE S @DIAXTFR@(DIAXI,"FR")=+X
S @DIAXTFR@(+X,"TO")=$P(X,U,9)
S @DIAXTFR@(+X,"PRT")=$P(X,U,3)
S @DIAXTFR@(+X,"P4")=$P(X,U,4)
S @DIAXTFR@(+X,"P2")=$P(X,U,2)
S @DIAXTFR@(+X,"P5")=$P(X,U,5)
S @DIAXTFR@(+X,"P7")=$P(X,U,7)
I DILL>1,$P(X,U,9)'=$P(X,U,10) S @DIAXTTO@(+$P(X,U,9),"PRT")=+$P(X,U,10)
Q
DR ;get fields
N DR,DRN,DRX,DRZ,FILE
S DR="",DRN=1,DRZ=0,FILE=@DIAXTFR@(DILL,"FR")
F S DRZ=$O(^DIPT(DIAXT,1,DIAXI,"F",DRZ)) Q:'DRZ I $D(^(DRZ,0)) S DRX=^(0) D
. S DR=DR_+DRX_";",FILE=@DIAXTFR@(DIAXI,"FR")
. S @DIAXTTO@(FILE,+DRX,+$P(DRX,U,5))=@DIAXTFR@(FILE,"TO")_U_$P(DRX,U,3)_U_$P(DRX,U,5)
. I $L(DR)>245 S @DIAXTFR@(FILE,"DR",DRN)=DR,DRN=DRN+1,DR=""
S:DR]"" @DIAXTFR@(FILE,"DR",DRN)=DR
Q
NEXTLVL ;
S DIAX(DILL,"DIAXI")=DIAXI,DILL=DILL+1
F DIAXI=DIAXI:0 S DIAXI=$O(^DIPT(DIAXT,1,DIAXI)) Q:DIAXI'=+DIAXI S X=^(DIAXI,0) D NEXTLVL2 Q:DIAXI=""
S DILL=DILL-1,DIAXI=DIAX(DILL,"DIAXI")
Q
NEXTLVL2 ;
I $P(X,U,2)<DILL S DIAXI="" Q
Q:$P(X,U,3)'=@DIAXTFR@(DIAX(DILL-1,"DIAXI"),"FR")
D FILE
D DR
D RECURSE
Q
RECURSE ;
D NEXTLVL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIAXT 1763 printed Oct 16, 2024@18:45:43 Page 2
DIAXT ;SFISC/DCM-GET EXTRACT TEMPLATE SPECS ;5/13/96 14:01
+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 ;
EN NEW DIAXI,DILL,DIAX
+1 SET DIAXTTO="^TMP($J,""DIAXTTO"")"
SET DIAXTFR="^TMP($J,""DIAXTFR"")"
+2 KILL @DIAXTTO,@DIAXTFR
+3 DO SPEC
+4 QUIT
SPEC ;get specs
+1 DO TOP
DO DR
+2 DO NEXTLVL
+3 QUIT
TOP ;get base file specs from extract template
+1 NEW X
+2 SET DIAXI=0
+3 SET DIAXI=$ORDER(^DIPT(DIAXT,1,DIAXI))
if DIAXI'>0
QUIT
SET X=^(DIAXI,0)
+4 SET DILL=$PIECE(X,U,2)
FILE SET @DIAXTFR@(DIAXI,"FR")=+X
+1 SET @DIAXTFR@(+X,"TO")=$PIECE(X,U,9)
+2 SET @DIAXTFR@(+X,"PRT")=$PIECE(X,U,3)
+3 SET @DIAXTFR@(+X,"P4")=$PIECE(X,U,4)
+4 SET @DIAXTFR@(+X,"P2")=$PIECE(X,U,2)
+5 SET @DIAXTFR@(+X,"P5")=$PIECE(X,U,5)
+6 SET @DIAXTFR@(+X,"P7")=$PIECE(X,U,7)
+7 IF DILL>1
IF $PIECE(X,U,9)'=$PIECE(X,U,10)
SET @DIAXTTO@(+$PIECE(X,U,9),"PRT")=+$PIECE(X,U,10)
+8 QUIT
DR ;get fields
+1 NEW DR,DRN,DRX,DRZ,FILE
+2 SET DR=""
SET DRN=1
SET DRZ=0
SET FILE=@DIAXTFR@(DILL,"FR")
+3 FOR
SET DRZ=$ORDER(^DIPT(DIAXT,1,DIAXI,"F",DRZ))
if 'DRZ
QUIT
IF $DATA(^(DRZ,0))
SET DRX=^(0)
Begin DoDot:1
+4 SET DR=DR_+DRX_";"
SET FILE=@DIAXTFR@(DIAXI,"FR")
+5 SET @DIAXTTO@(FILE,+DRX,+$PIECE(DRX,U,5))=@DIAXTFR@(FILE,"TO")_U_$PIECE(DRX,U,3)_U_$PIECE(DRX,U,5)
+6 IF $LENGTH(DR)>245
SET @DIAXTFR@(FILE,"DR",DRN)=DR
SET DRN=DRN+1
SET DR=""
End DoDot:1
+7 if DR]""
SET @DIAXTFR@(FILE,"DR",DRN)=DR
+8 QUIT
NEXTLVL ;
+1 SET DIAX(DILL,"DIAXI")=DIAXI
SET DILL=DILL+1
+2 FOR DIAXI=DIAXI:0
SET DIAXI=$ORDER(^DIPT(DIAXT,1,DIAXI))
if DIAXI'=+DIAXI
QUIT
SET X=^(DIAXI,0)
DO NEXTLVL2
if DIAXI=""
QUIT
+3 SET DILL=DILL-1
SET DIAXI=DIAX(DILL,"DIAXI")
+4 QUIT
NEXTLVL2 ;
+1 IF $PIECE(X,U,2)<DILL
SET DIAXI=""
QUIT
+2 if $PIECE(X,U,3)'=@DIAXTFR@(DIAX(DILL-1,"DIAXI"),"FR")
QUIT
+3 DO FILE
+4 DO DR
+5 DO RECURSE
+6 QUIT
RECURSE ;
+1 DO NEXTLVL
+2 QUIT
