DDXP32 ;SFISC/DPC-CREATE EXPORT TEMPLATE (CONT) ;12:44 PM 7 Jun 1999
;;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.
;
CAPDT ;
K DDXPFCAP,DDXPDT,DDXPATH N FCAP,NUMPC,C S C=","
F DDXPCNDX=1:1:DDXPTOTF D
. I DDXPNOUT(DDXPCNDX) Q
. S DDXPX=^TMP($J,"TIN",DDXPCNDX),DDXPTGFL=DDXPFINO,NUMPC=0 K FCAP
. D FLDFIND
. S DDXPFCAP(DDXPCNDX)=FCAP(NUMPC)
. F NUMPC=NUMPC-1:-1 Q:'$D(FCAP(NUMPC)) D
. . S DDXPFCAP(DDXPCNDX)=DDXPFCAP(DDXPCNDX)_" in "_FCAP(NUMPC)_" subfile"
. . Q
. K FCAP,NUMPC
. Q
I $D(DDXPATH) D MULTVER
K DDXPX,DDXPCNDX,DDXPTGFL,DDXPDD0 Q
FLDFIND ;
S NUMPC=NUMPC+1
I DDXPX=0 D Q
. S FCAP(NUMPC)="NUMBER",DDXPDT(DDXPCNDX)=4
. Q
I +DDXPX D
. S DDXPDD0="^DD("_DDXPTGFL_","_+DDXPX_",0)"
. Q
I DDXPX=+DDXPX D Q
. S FCAP(NUMPC)=$P(@DDXPDD0,U,1)
. S %=$P(@DDXPDD0,U,2),DDXPDT(DDXPCNDX)=$S(%["D":1,%["N":2,1:4) K %
. Q
I '+DDXPX D Q
. S DDXPDT(DDXPCNDX)=4
. I $E(DDXPX)=Q S FCAP(NUMPC)=DDXPX Q
. S %=$P(DDXPX,";Z;",2),%=$P(%,Q,2,99),%=$P(%,";",1),FCAP(NUMPC)=$E(%,1,($L(%)-1)) K %
. Q
MULT ;
S FCAP(NUMPC)=$P(@DDXPDD0,U,1)
S DDXPTGFL=+$P(@DDXPDD0,U,2)
I NUMPC=1 D
. N %,I,DONE S %=$P(DDXPX,C,1,$L(DDXPX,C)-1),DONE=0
. F I=2:1:$L(DDXPX,C) Q:DONE D
. . Q:+$P(%,C,I)
. . S %=$P(%,C,1,I-1),DONE=1
. . Q
. S DDXPATH(DDXPCNDX)=%
. Q
S DDXPX=$P(DDXPX,C,2,99)
G FLDFIND
SETFLD ;
S %L=$S($D(DDXPFLEN):";2///^S X=DDXPFLEN(DDXPFLD)",1:"")
S %F=$S($D(DDXPFFNM):";3///^S X=DDXPFFNM(DDXPFLD)",1:"")
S (DIC,DIE)="^DIPT("_DDXPXTNO_",100,",DA(1)=DDXPXTNO,DIC("P")=$P(^DD(.4,100,0),U,2),DIC(0)="L" K DO
F DDXPFLD=1:1:DDXPTOTF D
. I DDXPNOUT(DDXPFLD) Q
. S (DINUM,X)=DDXPFLD K DD D FILE^DICN
. S DA=DDXPFLD,DR="1////^S X=DDXPDT(DDXPFLD)"_%L_%F D ^DIE
. Q
K DIE,DIC,X,Y,DA,DR,%L,%F
Q
SETEMP ;
S DR="2///NOW;4///"_DDXPFINO_";5///"_DUZ_";8///3;105////"_DDXPFMNO S:$G(DDXPATH) DR=DR_";115///"_DDXPATH
S DA=DDXPXTNO,DIE="^DIPT(" D ^DIE K DIE,DA,DR
; Hard Set ReadAccess and WriteAccess
I $D(^DIPT(DDXPXTNO,0))#2,$D(DUZ(0))#2 D
. S $P(^DIPT(DDXPXTNO,0),U,3)=DUZ(0) ; Read Access
. S $P(^DIPT(DDXPXTNO,0),U,6)=DUZ(0) ; Write Access
S %X="^DIPT("_DDXPFDTM_",""DXS"",",%Y="^DIPT("_DDXPXTNO_",""DXS""," D %XY^%RCR K %X,%Y
S ^DIPT(DDXPXTNO,"SUB")=1
S ^DIPT(DDXPXTNO,"H")="@@"
Q
MULTVER ;
N I,MP,LP,MPC,LPC,NOMATCH S LP="",NOMATCH=0
F I=1:1:DDXPTOTF D Q:NOMATCH
. S MP=$G(DDXPATH(I)) Q:'MP
. I LP=MP Q
. I 'LP S LP=MP Q
. S LPC=$L(LP,C),MPC=$L(MP,C)
. I LPC=MPC S NOMATCH=1 Q
. I LPC>MPC D Q
. . I MP=$P(LP,C,1,MPC) Q
. . S NOMATCH=1
. . Q
. I LP=$P(MP,C,1,LPC) S LP=MP Q
. S NOMATCH=1
. Q
I 'NOMATCH S DDXPATH=LP Q
W !!,$C(7),"The "_DDXPFDNM_" template has fields in more than one multiple path."
W !,"Therefore, export of the data will not succeed."
W !,"Refer to the VA FileMan User Manual for more details.",!
S DDXPOUT=1
Q
QUOT ;
N QPC,Q1ST
I DDXPDT(DDXPFLD)=2 Q
S Q1ST=$S(DDXPNPC=DDXPRNPC:1,1:0)
S QPC="W $C(34)"_$S(Q1ST&(DDXPFLD=1):"",1:";X")
I Q1ST S DDXPNPC=QPC_T_DDXPNPC
E S DDXPNPC=DDXPNPC_T_QPC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDXP32 3326 printed Oct 16, 2024@18:44:45 Page 2
DDXP32 ;SFISC/DPC-CREATE EXPORT TEMPLATE (CONT) ;12:44 PM 7 Jun 1999
+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 ;
CAPDT ;
+1 KILL DDXPFCAP,DDXPDT,DDXPATH
NEW FCAP,NUMPC,C
SET C=","
+2 FOR DDXPCNDX=1:1:DDXPTOTF
Begin DoDot:1
+3 IF DDXPNOUT(DDXPCNDX)
QUIT
+4 SET DDXPX=^TMP($JOB,"TIN",DDXPCNDX)
SET DDXPTGFL=DDXPFINO
SET NUMPC=0
KILL FCAP
+5 DO FLDFIND
+6 SET DDXPFCAP(DDXPCNDX)=FCAP(NUMPC)
+7 FOR NUMPC=NUMPC-1:-1
if '$DATA(FCAP(NUMPC))
QUIT
Begin DoDot:2
+8 SET DDXPFCAP(DDXPCNDX)=DDXPFCAP(DDXPCNDX)_" in "_FCAP(NUMPC)_" subfile"
+9 QUIT
End DoDot:2
+10 KILL FCAP,NUMPC
+11 QUIT
End DoDot:1
+12 IF $DATA(DDXPATH)
DO MULTVER
+13 KILL DDXPX,DDXPCNDX,DDXPTGFL,DDXPDD0
QUIT
FLDFIND ;
+1 SET NUMPC=NUMPC+1
+2 IF DDXPX=0
Begin DoDot:1
+3 SET FCAP(NUMPC)="NUMBER"
SET DDXPDT(DDXPCNDX)=4
+4 QUIT
End DoDot:1
QUIT
+5 IF +DDXPX
Begin DoDot:1
+6 SET DDXPDD0="^DD("_DDXPTGFL_","_+DDXPX_",0)"
+7 QUIT
End DoDot:1
+8 IF DDXPX=+DDXPX
Begin DoDot:1
+9 SET FCAP(NUMPC)=$PIECE(@DDXPDD0,U,1)
+10 SET %=$PIECE(@DDXPDD0,U,2)
SET DDXPDT(DDXPCNDX)=$SELECT(%["D":1,%["N":2,1:4)
KILL %
+11 QUIT
End DoDot:1
QUIT
+12 IF '+DDXPX
Begin DoDot:1
+13 SET DDXPDT(DDXPCNDX)=4
+14 IF $EXTRACT(DDXPX)=Q
SET FCAP(NUMPC)=DDXPX
QUIT
+15 SET %=$PIECE(DDXPX,";Z;",2)
SET %=$PIECE(%,Q,2,99)
SET %=$PIECE(%,";",1)
SET FCAP(NUMPC)=$EXTRACT(%,1,($LENGTH(%)-1))
KILL %
+16 QUIT
End DoDot:1
QUIT
MULT ;
+1 SET FCAP(NUMPC)=$PIECE(@DDXPDD0,U,1)
+2 SET DDXPTGFL=+$PIECE(@DDXPDD0,U,2)
+3 IF NUMPC=1
Begin DoDot:1
+4 NEW %,I,DONE
SET %=$PIECE(DDXPX,C,1,$LENGTH(DDXPX,C)-1)
SET DONE=0
+5 FOR I=2:1:$LENGTH(DDXPX,C)
if DONE
QUIT
Begin DoDot:2
+6 if +$PIECE(%,C,I)
QUIT
+7 SET %=$PIECE(%,C,1,I-1)
SET DONE=1
+8 QUIT
End DoDot:2
+9 SET DDXPATH(DDXPCNDX)=%
+10 QUIT
End DoDot:1
+11 SET DDXPX=$PIECE(DDXPX,C,2,99)
+12 GOTO FLDFIND
SETFLD ;
+1 SET %L=$SELECT($DATA(DDXPFLEN):";2///^S X=DDXPFLEN(DDXPFLD)",1:"")
+2 SET %F=$SELECT($DATA(DDXPFFNM):";3///^S X=DDXPFFNM(DDXPFLD)",1:"")
+3 SET (DIC,DIE)="^DIPT("_DDXPXTNO_",100,"
SET DA(1)=DDXPXTNO
SET DIC("P")=$PIECE(^DD(.4,100,0),U,2)
SET DIC(0)="L"
KILL DO
+4 FOR DDXPFLD=1:1:DDXPTOTF
Begin DoDot:1
+5 IF DDXPNOUT(DDXPFLD)
QUIT
+6 SET (DINUM,X)=DDXPFLD
KILL DD
DO FILE^DICN
+7 SET DA=DDXPFLD
SET DR="1////^S X=DDXPDT(DDXPFLD)"_%L_%F
DO ^DIE
+8 QUIT
End DoDot:1
+9 KILL DIE,DIC,X,Y,DA,DR,%L,%F
+10 QUIT
SETEMP ;
+1 SET DR="2///NOW;4///"_DDXPFINO_";5///"_DUZ_";8///3;105////"_DDXPFMNO
if $GET(DDXPATH)
SET DR=DR_";115///"_DDXPATH
+2 SET DA=DDXPXTNO
SET DIE="^DIPT("
DO ^DIE
KILL DIE,DA,DR
+3 ; Hard Set ReadAccess and WriteAccess
+4 IF $DATA(^DIPT(DDXPXTNO,0))#2
IF $DATA(DUZ(0))#2
Begin DoDot:1
+5 ; Read Access
SET $PIECE(^DIPT(DDXPXTNO,0),U,3)=DUZ(0)
+6 ; Write Access
SET $PIECE(^DIPT(DDXPXTNO,0),U,6)=DUZ(0)
End DoDot:1
+7 SET %X="^DIPT("_DDXPFDTM_",""DXS"","
SET %Y="^DIPT("_DDXPXTNO_",""DXS"","
DO %XY^%RCR
KILL %X,%Y
+8 SET ^DIPT(DDXPXTNO,"SUB")=1
+9 SET ^DIPT(DDXPXTNO,"H")="@@"
+10 QUIT
MULTVER ;
+1 NEW I,MP,LP,MPC,LPC,NOMATCH
SET LP=""
SET NOMATCH=0
+2 FOR I=1:1:DDXPTOTF
Begin DoDot:1
+3 SET MP=$GET(DDXPATH(I))
if 'MP
QUIT
+4 IF LP=MP
QUIT
+5 IF 'LP
SET LP=MP
QUIT
+6 SET LPC=$LENGTH(LP,C)
SET MPC=$LENGTH(MP,C)
+7 IF LPC=MPC
SET NOMATCH=1
QUIT
+8 IF LPC>MPC
Begin DoDot:2
+9 IF MP=$PIECE(LP,C,1,MPC)
QUIT
+10 SET NOMATCH=1
+11 QUIT
End DoDot:2
QUIT
+12 IF LP=$PIECE(MP,C,1,LPC)
SET LP=MP
QUIT
+13 SET NOMATCH=1
+14 QUIT
End DoDot:1
if NOMATCH
QUIT
+15 IF 'NOMATCH
SET DDXPATH=LP
QUIT
+16 WRITE !!,$CHAR(7),"The "_DDXPFDNM_" template has fields in more than one multiple path."
+17 WRITE !,"Therefore, export of the data will not succeed."
+18 WRITE !,"Refer to the VA FileMan User Manual for more details.",!
+19 SET DDXPOUT=1
+20 QUIT
QUOT ;
+1 NEW QPC,Q1ST
+2 IF DDXPDT(DDXPFLD)=2
QUIT
+3 SET Q1ST=$SELECT(DDXPNPC=DDXPRNPC:1,1:0)
+4 SET QPC="W $C(34)"_$SELECT(Q1ST&(DDXPFLD=1):"",1:";X")
+5 IF Q1ST
SET DDXPNPC=QPC_T_DDXPNPC
+6 IF '$TEST
SET DDXPNPC=DDXPNPC_T_QPC
+7 QUIT
