VPRSDAVF ;SLC/MKB -- SDA Vfile utilities ;7/29/22 14:11
;;1.0;VIRTUAL PATIENT RECORD;**30**;Sep 01, 2011;Build 9
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^AUPNVSIT 2028
; ^AUTTHF 4295
; ^DIC(9.4 10048
; ^EDP(230 7180
; ^PXRMINDX 4290
; DILFD 2055
; DIQ 2056
; PXPXRM 4250
;
;
; Queries called from GET^DDE, returns DLIST(#)=ien
; Expects context variables DFN, DSTRT, DSTOP, DMAX
;
EXAMS ; -- V Exams (Physical Exams)
N FNUM S FNUM=9000010.13 G PXRM
;
HFACTORS ; -- V Health Factors (Health Concerns)
N FNUM S FNUM=9000010.23 G PXRM
;
CPT ; -- V CPT (Procedures)
N FNUM S FNUM=9000010.18 G PXRM
;
POV ; -- V POV (Diagnosis)
N FNUM S FNUM=9000010.07 G PXRM
;
IMMS ; -- V Immunizations
N FNUM S FNUM=9000010.11 G PXRM
;
PXRM ; -- Search PXRM index
N VPRSTART,VPRSTOP,VPRIDT,VPRN,ID
S VPRSTART=DSTRT,VPRSTOP=DSTOP,VPRN=0
D SORT^VPRDJ09 ;sort ^PXRMINDX into ^TMP("VPRPX",$J,IDT)
S VPRIDT=0 F S VPRIDT=$O(^TMP("VPRPX",$J,VPRIDT)) Q:VPRIDT<1 D Q:VPRN'<DMAX
. S ID=0 F S ID=$O(^TMP("VPRPX",$J,VPRIDT,ID)) Q:ID<1 D Q:VPRN'<DMAX
.. I FNUM=9000010.18,'$$VCPT(ID) Q
.. S VPRN=VPRN+1,DLIST(VPRN)=ID
K ^TMP("VPRPX",$J)
Q
;
ICR ; -- V Imm Contraindications/Refusals [query]
N ROOT,INDX,DATE,IDT,DA,TMP,VPRN S VPRN=0
; find records in ^PXRMINDX, sort by date
S ROOT="^PXRMINDX(9000010.707,""PCI"","_DFN,INDX=ROOT_")",ROOT=ROOT_","
F S INDX=$Q(@INDX) Q:INDX'[ROOT D
. S DATE=$QS(INDX,6) Q:DATE<DSTRT Q:DATE>DSTOP
. S DA=$QS(INDX,8),IDT=9999999-DATE,TMP(IDT,DA)=""
; return [DMAX] entries
S IDT=0 F S IDT=$O(TMP(IDT)) Q:IDT<1 D Q:VPRN'<DMAX
. S DA=0 F S DA=$O(TMP(IDT,DA)) Q:DA<1 S VPRN=VPRN+1,DLIST(VPRN)=DA
Q
;
HFCVR ; -- V Health Factors, for COVID Vaccination Refusal [query]
N ITEM,NAME,DATE,DA,X,VPRN S VPRN=0
S ITEM=+$O(^AUTTHF("B","VA-SARS-COV-2 VACCINE REFUSAL",0)) Q:ITEM<1 D CVR
S NAME="VA-SARS-COV-2 IMM REFUSAL"
F S NAME=$O(^AUTTHF("B",NAME)) Q:NAME'?1"VA-SARS-COV-2 IMM REFUSAL".E S ITEM=+$O(^(NAME,0)) D CVR
Q
CVR ;loop for ITEM
S DATE=DSTRT F S DATE=$O(^PXRMINDX(9000010.23,"PI",+$G(DFN),ITEM,DATE)) Q:DATE<1!(DATE>DSTOP) D Q:VPRN'<DMAX
. S DA=0 F S DA=$O(^PXRMINDX(9000010.23,"PI",+$G(DFN),ITEM,DATE,DA)) Q:DA<1 S VPRN=VPRN+1,DLIST(VPRN)=DA Q:VPRN'<DMAX
Q
;
;
XAM1 ; -- get info for single XAM record [ID Action]
; Expects/updates DIEN = #9000010.13 ien
; Returns VPRVST = #9000010 ien
; VPRVST0 = Visit zero node
; VPRXM array
K VPRXM D:$$ZERO^VPRENC("XAM",+DIEN) VXAM^PXPXRM(+DIEN,.VPRXM)
S VPRVST=$G(VPRXM("VISIT")),VPRVST0=$G(^AUPNVSIT(+VPRVST,0))
S VPRXM=DIEN,DIEN=+DIEN
Q
;
HF1 ; -- get info for single HF record [ID Action]
; Expects/updates DIEN = #9000010.23 ien
; Returns VPRVST = #9000010 ien
; VPRVST0 = Visit zero node
; VPRHF array
K VPRHF D:$$ZERO^VPRENC("HF",+DIEN) VHF^PXPXRM(+DIEN,.VPRHF)
S VPRVST=+$G(VPRHF("VISIT")),VPRVST0=$G(^AUPNVSIT(+VPRVST,0))
S VPRHF=DIEN,DIEN=+DIEN
Q
;
POV1 ; -- get info for single POV record [ID Action]
; Expects/updates DIEN = #9000010.07 ien
; Returns VPRVST = #9000010 ien
; VPRVST0 = Visit zero node
; VPREDP = #230 ien or 0
; VPRPOV array
K VPRPOV D:$$ZERO^VPRENC("POV",+DIEN) VPOV^PXPXRM(+DIEN,.VPRPOV)
S VPRVST=+$G(VPRPOV("VISIT")),VPRVST0=$G(^AUPNVSIT(VPRVST,0))
S VPREDP=+$O(^EDP(230,"V",VPRVST,0)) ;#230 ien if EDP, or 0
S VPRPOV=DIEN,DIEN=+DIEN
Q
;
POVNARR() ; -- build Original Text for POV
N NARR,MOD,Y S Y=""
S NARR=$G(VPRPOV("PROVIDER NARRATIVE")),MOD=$G(VPRPOV("MODIFIER"))
S:NARR Y=$$GET1^DIQ(9999999.27,NARR_",",.01)
I $L(MOD),$L(Y) S Y=$$EXTERNAL^DILFD(9000010.07,.06,,MOD)_" "_Y
Q Y
;
CPT1 ; -- get info for single V CPT record [ID Action]
; Expects/updates DIEN = #9000010.18 ien
; Returns VPRVST = #9000010 ien
; VPRVST0 = Visit zero node
; VPRCPT array
K VPRCPT D:$$ZERO^VPRENC("CPT",+DIEN) VCPT^PXPXRM(+DIEN,.VPRCPT)
S VPRVST=+$G(VPRCPT("VISIT")),VPRVST0=$G(^AUPNVSIT(VPRVST,0))
S VPRCPT=DIEN,DIEN=+DIEN
Q
;
VCPT(DA) ; -- ok to include V-CPT record in SDA?
N X0,CODE,PKG,VST S DA=+$G(DA)
; skip eval/mgt codes
S X0=$$ZERO^VPRENC("CPT",DA),CODE=$P(X0,U) I CODE>99200,CODE<99500 Q 0
; skip Surgery (duplicates of #130)
S PKG=$$GET1^DIQ(9000010.18,DA,81202,"I")
I PKG,$P($G(^DIC(9.4,PKG,0)),U,2)="SR" Q 0
; skip V IMMUNIZATIONS codes
S VST=+$P(X0,U,3)
I $$DUP(VST,CODE,"IMM") Q 0
; else ok
Q 1
;
DUP(VST,CPT,SUB) ; -- find V CPT match in VSUB file (IMM or SK)
N VFL,GBL,IEN,ITM,SYS,Y
I '$G(VST)!($G(CPT)="")!($G(SUB)="") Q 0
S VFL="^AUPNV"_SUB,GBL="^AUTT"_SUB,Y=0
S IEN=0 F S IEN=$O(@VFL@("AD",+VST,IEN)) Q:IEN<1 D Q:Y
. S ITM=+$G(@VFL@(IEN,0)),SYS=+$O(@GBL@(ITM,3,"B","CPT",0))
. I SYS,+$O(@GBL@(ITM,3,SYS,1,"B",CPT,0)) S Y=IEN
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAVF 5212 printed Nov 22, 2024@17:55:55 Page 2
VPRSDAVF ;SLC/MKB -- SDA Vfile utilities ;7/29/22 14:11
+1 ;;1.0;VIRTUAL PATIENT RECORD;**30**;Sep 01, 2011;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^AUPNVSIT 2028
+7 ; ^AUTTHF 4295
+8 ; ^DIC(9.4 10048
+9 ; ^EDP(230 7180
+10 ; ^PXRMINDX 4290
+11 ; DILFD 2055
+12 ; DIQ 2056
+13 ; PXPXRM 4250
+14 ;
+15 ;
+16 ; Queries called from GET^DDE, returns DLIST(#)=ien
+17 ; Expects context variables DFN, DSTRT, DSTOP, DMAX
+18 ;
EXAMS ; -- V Exams (Physical Exams)
+1 NEW FNUM
SET FNUM=9000010.13
GOTO PXRM
+2 ;
HFACTORS ; -- V Health Factors (Health Concerns)
+1 NEW FNUM
SET FNUM=9000010.23
GOTO PXRM
+2 ;
CPT ; -- V CPT (Procedures)
+1 NEW FNUM
SET FNUM=9000010.18
GOTO PXRM
+2 ;
POV ; -- V POV (Diagnosis)
+1 NEW FNUM
SET FNUM=9000010.07
GOTO PXRM
+2 ;
IMMS ; -- V Immunizations
+1 NEW FNUM
SET FNUM=9000010.11
GOTO PXRM
+2 ;
PXRM ; -- Search PXRM index
+1 NEW VPRSTART,VPRSTOP,VPRIDT,VPRN,ID
+2 SET VPRSTART=DSTRT
SET VPRSTOP=DSTOP
SET VPRN=0
+3 ;sort ^PXRMINDX into ^TMP("VPRPX",$J,IDT)
DO SORT^VPRDJ09
+4 SET VPRIDT=0
FOR
SET VPRIDT=$ORDER(^TMP("VPRPX",$JOB,VPRIDT))
if VPRIDT<1
QUIT
Begin DoDot:1
+5 SET ID=0
FOR
SET ID=$ORDER(^TMP("VPRPX",$JOB,VPRIDT,ID))
if ID<1
QUIT
Begin DoDot:2
+6 IF FNUM=9000010.18
IF '$$VCPT(ID)
QUIT
+7 SET VPRN=VPRN+1
SET DLIST(VPRN)=ID
End DoDot:2
if VPRN'<DMAX
QUIT
End DoDot:1
if VPRN'<DMAX
QUIT
+8 KILL ^TMP("VPRPX",$JOB)
+9 QUIT
+10 ;
ICR ; -- V Imm Contraindications/Refusals [query]
+1 NEW ROOT,INDX,DATE,IDT,DA,TMP,VPRN
SET VPRN=0
+2 ; find records in ^PXRMINDX, sort by date
+3 SET ROOT="^PXRMINDX(9000010.707,""PCI"","_DFN
SET INDX=ROOT_")"
SET ROOT=ROOT_","
+4 FOR
SET INDX=$QUERY(@INDX)
if INDX'[ROOT
QUIT
Begin DoDot:1
+5 SET DATE=$QSUBSCRIPT(INDX,6)
if DATE<DSTRT
QUIT
if DATE>DSTOP
QUIT
+6 SET DA=$QSUBSCRIPT(INDX,8)
SET IDT=9999999-DATE
SET TMP(IDT,DA)=""
End DoDot:1
+7 ; return [DMAX] entries
+8 SET IDT=0
FOR
SET IDT=$ORDER(TMP(IDT))
if IDT<1
QUIT
Begin DoDot:1
+9 SET DA=0
FOR
SET DA=$ORDER(TMP(IDT,DA))
if DA<1
QUIT
SET VPRN=VPRN+1
SET DLIST(VPRN)=DA
End DoDot:1
if VPRN'<DMAX
QUIT
+10 QUIT
+11 ;
HFCVR ; -- V Health Factors, for COVID Vaccination Refusal [query]
+1 NEW ITEM,NAME,DATE,DA,X,VPRN
SET VPRN=0
+2 SET ITEM=+$ORDER(^AUTTHF("B","VA-SARS-COV-2 VACCINE REFUSAL",0))
if ITEM<1
QUIT
DO CVR
+3 SET NAME="VA-SARS-COV-2 IMM REFUSAL"
+4 FOR
SET NAME=$ORDER(^AUTTHF("B",NAME))
if NAME'?1"VA-SARS-COV-2 IMM REFUSAL".E
QUIT
SET ITEM=+$ORDER(^(NAME,0))
DO CVR
+5 QUIT
CVR ;loop for ITEM
+1 SET DATE=DSTRT
FOR
SET DATE=$ORDER(^PXRMINDX(9000010.23,"PI",+$GET(DFN),ITEM,DATE))
if DATE<1!(DATE>DSTOP)
QUIT
Begin DoDot:1
+2 SET DA=0
FOR
SET DA=$ORDER(^PXRMINDX(9000010.23,"PI",+$GET(DFN),ITEM,DATE,DA))
if DA<1
QUIT
SET VPRN=VPRN+1
SET DLIST(VPRN)=DA
if VPRN'<DMAX
QUIT
End DoDot:1
if VPRN'<DMAX
QUIT
+3 QUIT
+4 ;
+5 ;
XAM1 ; -- get info for single XAM record [ID Action]
+1 ; Expects/updates DIEN = #9000010.13 ien
+2 ; Returns VPRVST = #9000010 ien
+3 ; VPRVST0 = Visit zero node
+4 ; VPRXM array
+5 KILL VPRXM
if $$ZERO^VPRENC("XAM",+DIEN)
DO VXAM^PXPXRM(+DIEN,.VPRXM)
+6 SET VPRVST=$GET(VPRXM("VISIT"))
SET VPRVST0=$GET(^AUPNVSIT(+VPRVST,0))
+7 SET VPRXM=DIEN
SET DIEN=+DIEN
+8 QUIT
+9 ;
HF1 ; -- get info for single HF record [ID Action]
+1 ; Expects/updates DIEN = #9000010.23 ien
+2 ; Returns VPRVST = #9000010 ien
+3 ; VPRVST0 = Visit zero node
+4 ; VPRHF array
+5 KILL VPRHF
if $$ZERO^VPRENC("HF",+DIEN)
DO VHF^PXPXRM(+DIEN,.VPRHF)
+6 SET VPRVST=+$GET(VPRHF("VISIT"))
SET VPRVST0=$GET(^AUPNVSIT(+VPRVST,0))
+7 SET VPRHF=DIEN
SET DIEN=+DIEN
+8 QUIT
+9 ;
POV1 ; -- get info for single POV record [ID Action]
+1 ; Expects/updates DIEN = #9000010.07 ien
+2 ; Returns VPRVST = #9000010 ien
+3 ; VPRVST0 = Visit zero node
+4 ; VPREDP = #230 ien or 0
+5 ; VPRPOV array
+6 KILL VPRPOV
if $$ZERO^VPRENC("POV",+DIEN)
DO VPOV^PXPXRM(+DIEN,.VPRPOV)
+7 SET VPRVST=+$GET(VPRPOV("VISIT"))
SET VPRVST0=$GET(^AUPNVSIT(VPRVST,0))
+8 ;#230 ien if EDP, or 0
SET VPREDP=+$ORDER(^EDP(230,"V",VPRVST,0))
+9 SET VPRPOV=DIEN
SET DIEN=+DIEN
+10 QUIT
+11 ;
POVNARR() ; -- build Original Text for POV
+1 NEW NARR,MOD,Y
SET Y=""
+2 SET NARR=$GET(VPRPOV("PROVIDER NARRATIVE"))
SET MOD=$GET(VPRPOV("MODIFIER"))
+3 if NARR
SET Y=$$GET1^DIQ(9999999.27,NARR_",",.01)
+4 IF $LENGTH(MOD)
IF $LENGTH(Y)
SET Y=$$EXTERNAL^DILFD(9000010.07,.06,,MOD)_" "_Y
+5 QUIT Y
+6 ;
CPT1 ; -- get info for single V CPT record [ID Action]
+1 ; Expects/updates DIEN = #9000010.18 ien
+2 ; Returns VPRVST = #9000010 ien
+3 ; VPRVST0 = Visit zero node
+4 ; VPRCPT array
+5 KILL VPRCPT
if $$ZERO^VPRENC("CPT",+DIEN)
DO VCPT^PXPXRM(+DIEN,.VPRCPT)
+6 SET VPRVST=+$GET(VPRCPT("VISIT"))
SET VPRVST0=$GET(^AUPNVSIT(VPRVST,0))
+7 SET VPRCPT=DIEN
SET DIEN=+DIEN
+8 QUIT
+9 ;
VCPT(DA) ; -- ok to include V-CPT record in SDA?
+1 NEW X0,CODE,PKG,VST
SET DA=+$GET(DA)
+2 ; skip eval/mgt codes
+3 SET X0=$$ZERO^VPRENC("CPT",DA)
SET CODE=$PIECE(X0,U)
IF CODE>99200
IF CODE<99500
QUIT 0
+4 ; skip Surgery (duplicates of #130)
+5 SET PKG=$$GET1^DIQ(9000010.18,DA,81202,"I")
+6 IF PKG
IF $PIECE($GET(^DIC(9.4,PKG,0)),U,2)="SR"
QUIT 0
+7 ; skip V IMMUNIZATIONS codes
+8 SET VST=+$PIECE(X0,U,3)
+9 IF $$DUP(VST,CODE,"IMM")
QUIT 0
+10 ; else ok
+11 QUIT 1
+12 ;
DUP(VST,CPT,SUB) ; -- find V CPT match in VSUB file (IMM or SK)
+1 NEW VFL,GBL,IEN,ITM,SYS,Y
+2 IF '$GET(VST)!($GET(CPT)="")!($GET(SUB)="")
QUIT 0
+3 SET VFL="^AUPNV"_SUB
SET GBL="^AUTT"_SUB
SET Y=0
+4 SET IEN=0
FOR
SET IEN=$ORDER(@VFL@("AD",+VST,IEN))
if IEN<1
QUIT
Begin DoDot:1
+5 SET ITM=+$GET(@VFL@(IEN,0))
SET SYS=+$ORDER(@GBL@(ITM,3,"B","CPT",0))
+6 IF SYS
IF +$ORDER(@GBL@(ITM,3,SYS,1,"B",CPT,0))
SET Y=IEN
End DoDot:1
if Y
QUIT
+7 QUIT Y
