- VPRSDADG ;SLC/MKB -- SDA DG PTF utilities ;04/25/22 15:29
- ;;1.0;VIRTUAL PATIENT RECORD;**30,35**;Apr 05, 2022;Build 16
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ; External References DBIA#
- ; ------------------- -----
- ; ^AUPNVSIT 2028
- ; ^DGPM 1865
- ; DGMSEUTL 5783
- ; DGPTFAPI 3157
- ; DGPTFUT 6130
- ; DGPTPXRM 4457
- ; DIC 2051
- ; ICDEX 5747
- ;
- DXQ ; -- get PTF Dx via Admissions
- ; Query called from GET^DDE, returns DLIST(#)=ien
- ; Expects context variables DFN, DSTRT, DSTOP, DMAX
- ;
- N IDT,END,VPRN,ADM,PTF,VPTF,I
- S IDT=9999999.9999999-DSTOP-.0000001,END=9999999.9999999-DSTRT,VPRN=0
- F S IDT=$O(^DGPM("ATID1",DFN,IDT)) Q:IDT<1!(IDT>END) D Q:VPRN'<DMAX
- . S ADM=0 F S ADM=$O(^DGPM("ATID1",DFN,IDT,ADM)) Q:ADM<1 D Q:VPRN'<DMAX
- .. S PTF=+$P($G(^DGPM(ADM,0)),U,16) Q:PTF<1 Q:'$$VNUM^VPRSDAV(ADM)
- .. ;Q:'$$GET1^DIQ(45,PTF,79,"I") ;no DXLS
- .. D RPC^DGPTFAPI(.VPTF,PTF) Q:VPTF(0)<1
- .. S:$L($P(VPTF(1),U,3)) VPRN=VPRN+1,DLIST(VPRN)=PTF
- .. F I=1:1:24 I $L($P(VPTF(2),U,I)) S VPRN=VPRN+1,DLIST(VPRN)=PTF_"-"_I
- Q
- ;
- DX1 ; -- get info for single PTF record [ID Action]
- ; Expects DIEN = #45 ien, returns VPRPOA & VPRPTF array
- N VST,VPTF,N,X,Y K VPRPTF
- S VPRPTF=$G(DIEN),DIEN=+$G(DIEN)
- S VST="" D I VST<1 S DDEOUT=1 Q
- . N ADM S ADM=$$FIND1^DIC(405,,"Q",DIEN,"APTF") Q:ADM<1
- . S:'$G(DFN) DFN=+$P($G(^DGPM(ADM,0)),U,3)
- . S VST=+$$VNUM^VPRSDAV(ADM) I 'VST!'$D(^AUPNVSIT(VST,0)) S VST=""
- S VPRPTF("VISIT")=VST
- D RPC^DGPTFAPI(.VPTF,DIEN) I VPTF(0)<1 S DDEOUT=1 Q
- S N=+$P(VPRPTF,"-",2),VPRPOA=$P($G(VPTF(3)),U,N+1)
- S X=$S(N:$P(VPTF(2),U,N),1:$P($G(VPTF(1)),U,3))
- S Y=$$CODEBA^ICDEX(X,80) I Y<1 S DDEOUT=1 Q
- S VPRPTF("DX")=Y_U_X ;ien^code
- D PTF^DGPTPXRM(DIEN,.VPRPTF)
- Q
- ;
- OPQ ; -- get PTF 601 procedure codes via Admissions
- ; Query called from GET^DDE, returns DLIST(#)=ien
- ; Expects context variables DFN, DSTRT, DSTOP, DMAX
- ;
- N IDT,END,VPRN,ADM,PTF,VPTF,DA,STR,P,X
- S IDT=9999999.9999999-DSTOP-.0000001,END=9999999.9999999-DSTRT,VPRN=0
- F S IDT=$O(^DGPM("ATID1",DFN,IDT)) Q:IDT<1!(IDT>END) D Q:VPRN'<DMAX
- . S ADM=0 F S ADM=$O(^DGPM("ATID1",DFN,IDT,ADM)) Q:ADM<1 D Q:VPRN'<DMAX
- .. S PTF=+$P($G(^DGPM(ADM,0)),U,16) Q:PTF<1 Q:'$$VNUM^VPRSDAV(ADM)
- .. D PTFIEN^DGPTFUT(601,PTF,.VPTF)
- .. S DA=0 F S DA=$O(VPTF(DA)) Q:DA<1 D
- ... S STR=$$STR601^DGPTFUT(PTF,DA)
- ... F P=1:1:25 S X=$P(STR,U,P) S:X VPRN=VPRN+1,DLIST(VPRN)=DA_","_PTF_"-"_P
- Q
- ;
- OP1 ; -- get info for single PTF record [ID Action]
- ; Expects DIEN = #45 iens, returns VPRPTF & VPRVST
- N VST,VPTF,X,Y
- S VPRPTF=$G(DIEN),DIEN=$P($G(DIEN),"-") ;DA,PTF-#
- S VST="" D I VST<1 S DDEOUT=1 Q
- . N ADM,PTF
- . S PTF=+$P(VPRPTF,",",2),ADM=$$FIND1^DIC(405,,"Q",PTF,"APTF") Q:'ADM
- . S:'$G(DFN) DFN=$P($G(^DGPM(ADM,0)),U,3)
- . S VST=+$$VNUM^VPRSDAV(ADM) I 'VST!'$D(^AUPNVSIT(VST,0)) S VST=""
- S VPRVST=VST
- Q
- ;
- MSE ;Using GETMSE^DGMSEUTL, build array for use in entity VPR PATIENT MSE ALL
- N BRANCH,COUNT,COMP,DA,DONE,DTYP,EDATA,EDATE,I,SDATE,SERVNO,SUB,EDATE2,SDATE2,BRANCH2,DTYP2,VPRI
- S COUNT=0,EDATE=""
- K VPRMS,VPRSV D:$G(DFN) GETMSE^DGMSEUTL(DFN,.VPRMS)
- ;Retrieve all MSE
- S VPRI=0 F S VPRI=$O(VPRMS(VPRI)) Q:'VPRI D
- .;DJS, skip an MSE that has Future Discharge Date; DG*5.3*935
- .S EDATA=$G(VPRMS(VPRI)) Q:EDATA=""!($P(EDATA,U,8)'="")
- .S EDATE=$P(EDATA,U),EDATE2=$$DATE^VPRSDA(EDATE,1)
- .S SDATE=$P(EDATA,U,2),SDATE2=$$DATE^VPRSDA(SDATE,1),EDATE2=$$DATE^VPRSDA(EDATE,1)
- .S BRANCH=$P(EDATA,U,3),COMP=$P(EDATA,U,4),BRANCH2=$$GET1^DIQ(23,BRANCH,.01)
- .S SERVNO=$P(EDATA,U,5),DTYP=$P(EDATA,U,6),DTYP2=$$GET1^DIQ(25,DTYP,.01)
- .S COUNT=COUNT+1
- .S SUB=1,VPRSV(COUNT)=$S($G(BRANCH):1,1:"")
- .S VPRSV(COUNT,SUB)=DTYP_U_DTYP2
- .S VPRSV(COUNT,SUB+1)=BRANCH_U_BRANCH2
- .S VPRSV(COUNT,SUB+2)=EDATE_U_EDATE2
- .S VPRSV(COUNT,SUB+3)=SDATE_U_SDATE2
- .S VPRSV(COUNT,SUB+4)=SERVNO
- .S VPRSV(COUNT,SUB+5)=COMP_U_$$EXTERNAL^DILFD(2.3216,.04,,$G(COMP))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDADG 4150 printed Feb 19, 2025@00:12:16 Page 2
- VPRSDADG ;SLC/MKB -- SDA DG PTF utilities ;04/25/22 15:29
- +1 ;;1.0;VIRTUAL PATIENT RECORD;**30,35**;Apr 05, 2022;Build 16
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; External References DBIA#
- +5 ; ------------------- -----
- +6 ; ^AUPNVSIT 2028
- +7 ; ^DGPM 1865
- +8 ; DGMSEUTL 5783
- +9 ; DGPTFAPI 3157
- +10 ; DGPTFUT 6130
- +11 ; DGPTPXRM 4457
- +12 ; DIC 2051
- +13 ; ICDEX 5747
- +14 ;
- DXQ ; -- get PTF Dx via Admissions
- +1 ; Query called from GET^DDE, returns DLIST(#)=ien
- +2 ; Expects context variables DFN, DSTRT, DSTOP, DMAX
- +3 ;
- +4 NEW IDT,END,VPRN,ADM,PTF,VPTF,I
- +5 SET IDT=9999999.9999999-DSTOP-.0000001
- SET END=9999999.9999999-DSTRT
- SET VPRN=0
- +6 FOR
- SET IDT=$ORDER(^DGPM("ATID1",DFN,IDT))
- if IDT<1!(IDT>END)
- QUIT
- Begin DoDot:1
- +7 SET ADM=0
- FOR
- SET ADM=$ORDER(^DGPM("ATID1",DFN,IDT,ADM))
- if ADM<1
- QUIT
- Begin DoDot:2
- +8 SET PTF=+$PIECE($GET(^DGPM(ADM,0)),U,16)
- if PTF<1
- QUIT
- if '$$VNUM^VPRSDAV(ADM)
- QUIT
- +9 ;Q:'$$GET1^DIQ(45,PTF,79,"I") ;no DXLS
- +10 DO RPC^DGPTFAPI(.VPTF,PTF)
- if VPTF(0)<1
- QUIT
- +11 if $LENGTH($PIECE(VPTF(1),U,3))
- SET VPRN=VPRN+1
- SET DLIST(VPRN)=PTF
- +12 FOR I=1:1:24
- IF $LENGTH($PIECE(VPTF(2),U,I))
- SET VPRN=VPRN+1
- SET DLIST(VPRN)=PTF_"-"_I
- End DoDot:2
- if VPRN'<DMAX
- QUIT
- End DoDot:1
- if VPRN'<DMAX
- QUIT
- +13 QUIT
- +14 ;
- DX1 ; -- get info for single PTF record [ID Action]
- +1 ; Expects DIEN = #45 ien, returns VPRPOA & VPRPTF array
- +2 NEW VST,VPTF,N,X,Y
- KILL VPRPTF
- +3 SET VPRPTF=$GET(DIEN)
- SET DIEN=+$GET(DIEN)
- +4 SET VST=""
- Begin DoDot:1
- +5 NEW ADM
- SET ADM=$$FIND1^DIC(405,,"Q",DIEN,"APTF")
- if ADM<1
- QUIT
- +6 if '$GET(DFN)
- SET DFN=+$PIECE($GET(^DGPM(ADM,0)),U,3)
- +7 SET VST=+$$VNUM^VPRSDAV(ADM)
- IF 'VST!'$DATA(^AUPNVSIT(VST,0))
- SET VST=""
- End DoDot:1
- IF VST<1
- SET DDEOUT=1
- QUIT
- +8 SET VPRPTF("VISIT")=VST
- +9 DO RPC^DGPTFAPI(.VPTF,DIEN)
- IF VPTF(0)<1
- SET DDEOUT=1
- QUIT
- +10 SET N=+$PIECE(VPRPTF,"-",2)
- SET VPRPOA=$PIECE($GET(VPTF(3)),U,N+1)
- +11 SET X=$SELECT(N:$PIECE(VPTF(2),U,N),1:$PIECE($GET(VPTF(1)),U,3))
- +12 SET Y=$$CODEBA^ICDEX(X,80)
- IF Y<1
- SET DDEOUT=1
- QUIT
- +13 ;ien^code
- SET VPRPTF("DX")=Y_U_X
- +14 DO PTF^DGPTPXRM(DIEN,.VPRPTF)
- +15 QUIT
- +16 ;
- OPQ ; -- get PTF 601 procedure codes via Admissions
- +1 ; Query called from GET^DDE, returns DLIST(#)=ien
- +2 ; Expects context variables DFN, DSTRT, DSTOP, DMAX
- +3 ;
- +4 NEW IDT,END,VPRN,ADM,PTF,VPTF,DA,STR,P,X
- +5 SET IDT=9999999.9999999-DSTOP-.0000001
- SET END=9999999.9999999-DSTRT
- SET VPRN=0
- +6 FOR
- SET IDT=$ORDER(^DGPM("ATID1",DFN,IDT))
- if IDT<1!(IDT>END)
- QUIT
- Begin DoDot:1
- +7 SET ADM=0
- FOR
- SET ADM=$ORDER(^DGPM("ATID1",DFN,IDT,ADM))
- if ADM<1
- QUIT
- Begin DoDot:2
- +8 SET PTF=+$PIECE($GET(^DGPM(ADM,0)),U,16)
- if PTF<1
- QUIT
- if '$$VNUM^VPRSDAV(ADM)
- QUIT
- +9 DO PTFIEN^DGPTFUT(601,PTF,.VPTF)
- +10 SET DA=0
- FOR
- SET DA=$ORDER(VPTF(DA))
- if DA<1
- QUIT
- Begin DoDot:3
- +11 SET STR=$$STR601^DGPTFUT(PTF,DA)
- +12 FOR P=1:1:25
- SET X=$PIECE(STR,U,P)
- if X
- SET VPRN=VPRN+1
- SET DLIST(VPRN)=DA_","_PTF_"-"_P
- End DoDot:3
- End DoDot:2
- if VPRN'<DMAX
- QUIT
- End DoDot:1
- if VPRN'<DMAX
- QUIT
- +13 QUIT
- +14 ;
- OP1 ; -- get info for single PTF record [ID Action]
- +1 ; Expects DIEN = #45 iens, returns VPRPTF & VPRVST
- +2 NEW VST,VPTF,X,Y
- +3 ;DA,PTF-#
- SET VPRPTF=$GET(DIEN)
- SET DIEN=$PIECE($GET(DIEN),"-")
- +4 SET VST=""
- Begin DoDot:1
- +5 NEW ADM,PTF
- +6 SET PTF=+$PIECE(VPRPTF,",",2)
- SET ADM=$$FIND1^DIC(405,,"Q",PTF,"APTF")
- if 'ADM
- QUIT
- +7 if '$GET(DFN)
- SET DFN=$PIECE($GET(^DGPM(ADM,0)),U,3)
- +8 SET VST=+$$VNUM^VPRSDAV(ADM)
- IF 'VST!'$DATA(^AUPNVSIT(VST,0))
- SET VST=""
- End DoDot:1
- IF VST<1
- SET DDEOUT=1
- QUIT
- +9 SET VPRVST=VST
- +10 QUIT
- +11 ;
- MSE ;Using GETMSE^DGMSEUTL, build array for use in entity VPR PATIENT MSE ALL
- +1 NEW BRANCH,COUNT,COMP,DA,DONE,DTYP,EDATA,EDATE,I,SDATE,SERVNO,SUB,EDATE2,SDATE2,BRANCH2,DTYP2,VPRI
- +2 SET COUNT=0
- SET EDATE=""
- +3 KILL VPRMS,VPRSV
- if $GET(DFN)
- DO GETMSE^DGMSEUTL(DFN,.VPRMS)
- +4 ;Retrieve all MSE
- +5 SET VPRI=0
- FOR
- SET VPRI=$ORDER(VPRMS(VPRI))
- if 'VPRI
- QUIT
- Begin DoDot:1
- +6 ;DJS, skip an MSE that has Future Discharge Date; DG*5.3*935
- +7 SET EDATA=$GET(VPRMS(VPRI))
- if EDATA=""!($PIECE(EDATA,U,8)'="")
- QUIT
- +8 SET EDATE=$PIECE(EDATA,U)
- SET EDATE2=$$DATE^VPRSDA(EDATE,1)
- +9 SET SDATE=$PIECE(EDATA,U,2)
- SET SDATE2=$$DATE^VPRSDA(SDATE,1)
- SET EDATE2=$$DATE^VPRSDA(EDATE,1)
- +10 SET BRANCH=$PIECE(EDATA,U,3)
- SET COMP=$PIECE(EDATA,U,4)
- SET BRANCH2=$$GET1^DIQ(23,BRANCH,.01)
- +11 SET SERVNO=$PIECE(EDATA,U,5)
- SET DTYP=$PIECE(EDATA,U,6)
- SET DTYP2=$$GET1^DIQ(25,DTYP,.01)
- +12 SET COUNT=COUNT+1
- +13 SET SUB=1
- SET VPRSV(COUNT)=$SELECT($GET(BRANCH):1,1:"")
- +14 SET VPRSV(COUNT,SUB)=DTYP_U_DTYP2
- +15 SET VPRSV(COUNT,SUB+1)=BRANCH_U_BRANCH2
- +16 SET VPRSV(COUNT,SUB+2)=EDATE_U_EDATE2
- +17 SET VPRSV(COUNT,SUB+3)=SDATE_U_SDATE2
- +18 SET VPRSV(COUNT,SUB+4)=SERVNO
- +19 SET VPRSV(COUNT,SUB+5)=COMP_U_$$EXTERNAL^DILFD(2.3216,.04,,$GET(COMP))
- End DoDot:1
- +20 QUIT
