- DDXP32 ;SFISC/DPC-CREATE EXPORT TEMPLATE (CONT) ;12:44 PM 7 Jun 1999 [ 04/02/2003 8:25 AM ]
- ;;22.0;VA FileMan;**1001**;APR 1, 2003
- ;;22.0;VA FileMan;**9**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- DDXP32 ;SFISC/DPC-CREATE EXPORT TEMPLATE (CONT) ;12:44 PM 7 Jun 1999 [ 04/02/2003 8:25 AM ]
- +1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
- +2 ;;22.0;VA FileMan;**9**;Mar 30, 1999
- +3 ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
