DIAXT.m

DIAXT ;SFISC/DCM-GET EXTRACT TEMPLATE SPECS ;5/13/96  14:01

 ;;22.0;VA FileMan;;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

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

DIAXT     ;SFISC/DCM-GET EXTRACT TEMPLATE SPECS ;5/13/96  14:01

 +1       ;;22.0;VA FileMan;;Mar 30, 1999

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

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