VPRSDAQ ;SLC/MKB -- SDA queries ;11/8/18 14:11
;;1.0;VIRTUAL PATIENT RECORD;**8,10,20,26,25,27,28,30**;Sep 01, 2011;Build 9
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^AUTTHF 4295
; ^GMR(120.86 3449
; ^LR 525
; ^PXRMINDX 4290
; %DT 10003
; GMPLUTL2 2741
; GMRADPT 10099
; GMRCSLM1, ^TMP("GMRCR",$J) 2740
; GMRVUT0, ^UTILITY($J) 1446
; IBBAPI 4419
; LR7OR1, ^TMP("LRRR",$J) 2503
; MDPS1,^TMP("MDHSP",$J) 4230
; RMIMRP 4745
; TIUPP3, ^TMP("TIUPPCV",$J) 2864
; TIUVPR 6077
; WVRPCVPR, ^TMP("WVPREGST" 7199
;
; VistA application queries, return DLIST(#) = record ID
; Expects context variables from ^DDEGET [DFN, DSTRT, DSTOP, DMAX]
;
PROBLEMS ; -- Problem List
N ID,VPRSTS,VPRPROB,VPRN,X
S VPRSTS=$G(FILTER("status")) ;default = all problems
D LIST^GMPLUTL2(.VPRPROB,DFN,VPRSTS)
S VPRN=0 F S VPRN=$O(VPRPROB(VPRN)) Q:(VPRN<1)!(VPRN>DMAX) D
. S X=$P(VPRPROB(VPRN),U,6) I X,(X<DSTRT)!(X>DSTOP) Q ;last updated
. S DLIST(VPRN)=+VPRPROB(VPRN)
Q
;
ALLERGYS ; -- Allergies/Adverse Reactions
N GMRA,VPRN,ID
S VPRN=0,GMRA="0^0^111^0^1"
I $L($T(EN2^GMRADPT)) D EN2^GMRADPT I 1
E D EN1^GMRADPT
;I 'GMRAL Q ;D NKA^VPRDJ02 Q
S ID=0 F S ID=+$O(GMRAL(ID)) Q:ID<1 S VPRN=VPRN+1,DLIST(VPRN)=ID Q:VPRN'<DMAX
Q
;
ASSESS ; -- get Assessment #120.86 for patient if none or NKA
Q:'$G(DFN) Q:$P($G(^GMR(120.86,DFN,0)),U,2) ;has allergies
S DLIST(1)=DFN
Q
;
DOCUMENT ; -- Text Integration Utilities
N VPRY,VPRI,VPRN
D LIST^TIUVPR(.VPRY,DFN,38,DSTRT,DSTOP)
S VPRN=0,VPRI="COUNT"
F S VPRI=$O(@VPRY@(VPRI),-1) Q:VPRI<1 D Q:VPRN'<DMAX
. S VPRN=VPRN+1,DLIST(VPRN)=+VPRI
K @VPRY
Q
;
ADVDIR ; -- Adv Directive (alerts)
N I,AD,TIUD,CNT,STS,NXT
D:$G(DFN) ENCOVER^TIUPP3(DFN)
; ^TMP = IEN^Acronym^Category Name^Optional Subject^Date/Time^Optional Addendum
; put AD in Ref D/T order
S I=0 F S I=$O(^TMP("TIUPPCV",$J,I)) Q:I<1 S AD=$G(^(I)) I $P(AD,U,2)="D" S TIUD($P(AD,U,5))=AD
Q:'$O(TIUD(0)) ;no AD's for patient
; get latest AD, ck if in/active
S I=+$O(TIUD(""),-1),AD=$G(TIUD(I)),STS="A",NXT=""
I AD["RESCIND"!($L($P(AD,U,6))) D ;inactive
. N ADD,%DT,X,Y S ADD=$P(AD,U,6),STS="I"
. S X=$P(AD,"addendum ",2),X=$P(X,")")
. I $L(X) S %DT="TX" D ^%DT S:Y>0 NXT=Y ;end=addendum d/t
S CNT=1,DLIST(CNT)=+AD_U_STS_U_NXT,NXT=$P(AD,U,5)
; add remaining AD's as inactive, using next AD's Ref D/T as its end
S STS="I" F S I=$O(TIUD(I),-1) Q:I<1 S AD=$G(TIUD(I)) D
. S CNT=CNT+1,DLIST(CNT)=+AD_U_STS_U_NXT
. S NXT=$P(AD,U,5)
Q
;
LRAP ; -- LR Anatomic Pathology reports [expects LRDFN]
N SUB,IDT,VPRN,CTR S VPRN=0
D RR^LR7OR1(DFN,,DSTRT,DSTOP,"AP")
S SUB="" F S SUB=$O(^TMP("LRRR",$J,DFN,SUB)) Q:SUB="" D
. S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,SUB,IDT)) Q:IDT<1 I $O(^(IDT,0)) D Q:VPRN'<DMAX
.. Q:$O(^LR(LRDFN,SUB,IDT,.05,0)) ;report in TIU
.. Q:'$P($G(^LR(LRDFN,SUB,IDT,0)),U,11) ;not final results
.. S VPRN=VPRN+1,DLIST(VPRN)=IDT_","_LRDFN_"~"_SUB
K ^TMP("LRRR",$J,DFN)
Q
;
LRMI ; -- LR Microbiology reports [expects LRDFN]
N IDT,VPRN,CTR S VPRN=0
D RR^LR7OR1(DFN,,DSTRT,DSTOP,"MI")
S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,"MI",IDT)) Q:IDT<1 I $O(^(IDT,0)) D Q:VPRN'<DMAX
. ;Q:'$P($G(^LR(LRDFN,"MI",IDT,0)),U,3) ;not final results
. Q:'$$MI1^VPRSDAB(LRDFN,IDT) ;not final results
. S VPRN=VPRN+1,DLIST(VPRN)=IDT_","_LRDFN_"~MI"
K ^TMP("LRRR",$J,DFN)
Q
;
CONSULTS ; -- Consult/Request Tracking
N VPRN,VPRX,GMRCDA,GMRCGRP,GMRCSEX,TITLE
D OER^GMRCSLM1(DFN,"",DSTRT,DSTOP,"") S VPRN=0
F S VPRN=$O(^TMP("GMRCR",$J,"CS",VPRN)) Q:VPRN<1!(VPRN>DMAX) D
. S VPRX=$G(^TMP("GMRCR",$J,"CS",VPRN,0)) Q:+VPRX<1
. S DLIST(VPRN)=+VPRX
K ^TMP("GMRCR",$J,"CS")
Q
;
CPROCS ; -- Clinical Procedures
N VPRN,VPRX,I,ID S VPRN=0
D MDPS1^VPRDJ03(DFN,DSTRT,DSTOP,DMAX) ;gets ^TMP("MDHSP",$J)
S I=0 F S I=$O(^TMP("MDHSP",$J,I)) Q:I<1 S VPRX=$G(^(I)) I $P(VPRX,U,3)="PR702" D Q:VPRN'<DMAX
. Q:'$P(VPRX,U,14) ;no document yet (so no enc#)
. S ^TMP("MDHSP",$J,"IEN",+$P(VPRX,U,2))=I
. S VPRN=VPRN+1,DLIST(VPRN)=+$P(VPRX,U,2)
;K ^TMP("MDHSP",$J)
Q
;
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^VPRSDAVF(ID) Q
.. S VPRN=VPRN+1,DLIST(VPRN)=ID
K ^TMP("VPRPX",$J)
Q
;
ICR ; -- V Imm Contraindications/Refusals
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
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
;
HFS ; -- V Health Factors, for Social History
N ITEM,DATE,DA,VPRN S VPRN=0
S ITEM=0 F S ITEM=$O(^PXRMINDX(9000010.23,"PI",+$G(DFN),ITEM)) Q:ITEM<1 I $$SOCHIST(ITEM) D Q:VPRN'<DMAX
. 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_U_ITEM Q:VPRN'<DMAX
Q
;
SOCHIST(IEN) ; -- find social history factors
N X S X=$P($G(^AUTTHF(+IEN,0)),U)
I (X["TOBACCO")!(X["SMOK") Q 1
;I (X["LIVES")!(X["LIVING") Q 1
;I (X["RELIGIO")!(X["SPIRIT") Q 1
Q 0
;
WVPL ; -- Women's Health Pregnancy Log, for Social History
K ^TMP("WVPREGST",$J)
D BASELINE^WVRPCVPR(DFN)
S:$D(^TMP("WVPREGST",$J,"BASELINE")) DLIST(1)=DFN
;S:$G(^TMP("WVPREGST",$J,"BASELINE","TO TIME"))'<$$FMADD^XLFDT(DT,-14) DLIST(1)=DFN
Q
;
VITALS ; -- GMR Vital Measurements
N GMRVSTR,VPRIDT,VPRTYP,ID,VPRN
S GMRVSTR="BP;T;R;P;HT;WT;CVP;CG;PO2;PN"
S GMRVSTR(0)=DSTRT_U_DSTOP_U_DMAX_"^1"
D EN1^GMRVUT0 S VPRN=0
S VPRIDT=0 F S VPRIDT=$O(^UTILITY($J,"GMRVD",VPRIDT)) Q:VPRIDT<1 D Q:VPRN'<DMAX
. S VPRTYP="" F S VPRTYP=$O(^UTILITY($J,"GMRVD",VPRIDT,VPRTYP)) Q:VPRTYP="" D
.. S ID=$O(^UTILITY($J,"GMRVD",VPRIDT,VPRTYP,0)) Q:'ID
.. S VPRN=VPRN+1,DLIST(VPRN)=ID
.. S ^TMP("VPRGMV",$J,ID)=$G(^UTILITY($J,"GMRVD",VPRIDT,VPRTYP,ID))
K ^UTILITY($J,"GMRVD")
Q
;
INS ; -- Insurance
N NUM,I,VPRDT,VPRSTS,VPRX
S VPRSTS=$G(FILTER("status"),"RB"),VPRDT=DT
I VPRSTS["A" S VPRDT="" ;no date if requesting inactive policies
S:$G(DFN) NUM=$$INSUR^IBBAPI(DFN,VPRDT,VPRSTS,.VPRX,"*") Q:NUM<1
S I=0 F S I=$O(VPRX("IBBAPI","INSUR",I)) Q:I<1 S DLIST(I)=I
M VPRINS=VPRX("IBBAPI","INSUR")
Q
;
FIM ; -- Functional Independence Measurements
N VPRS,VPRN,VPRY,ADM,VPRCNT,RMIMTIME
D PRM^RMIMRP(.VPRSITE) Q:'$O(VPRSITE(1))
S DFN=+$G(DFN) Q:DFN<1
S VPRCNT=0
S VPRS=1 F S VPRS=$O(VPRSITE(VPRS)) Q:VPRS<1 D
. S VPRN=DFN_U_VPRSITE(VPRS)
. D LC^RMIMRP(.VPRY,VPRN) Q:VPRY(1)<1
. S VPRN=1 F S VPRN=$O(VPRY(VPRN)) Q:VPRN<1 D Q:VPRCNT'<DMAX
.. S ADM=$$DATE($P(VPRY(VPRN),U,4)) Q:ADM<DSTRT Q:ADM>DSTOP
.. S VPRCNT=VPRCNT+1,DLIST(VPRCNT)=+VPRY(VPRN)
Q
;
DATE(X) ; -- Return internal form of date X
N %DT,Y
S %DT="" D ^%DT S:Y<1 Y=X
Q Y
;
NOQ ; -- tag for Entities that should not execute a query
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAQ 8478 printed Sep 23, 2025@20:22:20 Page 2
VPRSDAQ ;SLC/MKB -- SDA queries ;11/8/18 14:11
+1 ;;1.0;VIRTUAL PATIENT RECORD;**8,10,20,26,25,27,28,30**;Sep 01, 2011;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^AUTTHF 4295
+7 ; ^GMR(120.86 3449
+8 ; ^LR 525
+9 ; ^PXRMINDX 4290
+10 ; %DT 10003
+11 ; GMPLUTL2 2741
+12 ; GMRADPT 10099
+13 ; GMRCSLM1, ^TMP("GMRCR",$J) 2740
+14 ; GMRVUT0, ^UTILITY($J) 1446
+15 ; IBBAPI 4419
+16 ; LR7OR1, ^TMP("LRRR",$J) 2503
+17 ; MDPS1,^TMP("MDHSP",$J) 4230
+18 ; RMIMRP 4745
+19 ; TIUPP3, ^TMP("TIUPPCV",$J) 2864
+20 ; TIUVPR 6077
+21 ; WVRPCVPR, ^TMP("WVPREGST" 7199
+22 ;
+23 ; VistA application queries, return DLIST(#) = record ID
+24 ; Expects context variables from ^DDEGET [DFN, DSTRT, DSTOP, DMAX]
+25 ;
PROBLEMS ; -- Problem List
+1 NEW ID,VPRSTS,VPRPROB,VPRN,X
+2 ;default = all problems
SET VPRSTS=$GET(FILTER("status"))
+3 DO LIST^GMPLUTL2(.VPRPROB,DFN,VPRSTS)
+4 SET VPRN=0
FOR
SET VPRN=$ORDER(VPRPROB(VPRN))
if (VPRN<1)!(VPRN>DMAX)
QUIT
Begin DoDot:1
+5 ;last updated
SET X=$PIECE(VPRPROB(VPRN),U,6)
IF X
IF (X<DSTRT)!(X>DSTOP)
QUIT
+6 SET DLIST(VPRN)=+VPRPROB(VPRN)
End DoDot:1
+7 QUIT
+8 ;
ALLERGYS ; -- Allergies/Adverse Reactions
+1 NEW GMRA,VPRN,ID
+2 SET VPRN=0
SET GMRA="0^0^111^0^1"
+3 IF $LENGTH($TEXT(EN2^GMRADPT))
DO EN2^GMRADPT
IF 1
+4 IF '$TEST
DO EN1^GMRADPT
+5 ;I 'GMRAL Q ;D NKA^VPRDJ02 Q
+6 SET ID=0
FOR
SET ID=+$ORDER(GMRAL(ID))
if ID<1
QUIT
SET VPRN=VPRN+1
SET DLIST(VPRN)=ID
if VPRN'<DMAX
QUIT
+7 QUIT
+8 ;
ASSESS ; -- get Assessment #120.86 for patient if none or NKA
+1 ;has allergies
if '$GET(DFN)
QUIT
if $PIECE($GET(^GMR(120.86,DFN,0)),U,2)
QUIT
+2 SET DLIST(1)=DFN
+3 QUIT
+4 ;
DOCUMENT ; -- Text Integration Utilities
+1 NEW VPRY,VPRI,VPRN
+2 DO LIST^TIUVPR(.VPRY,DFN,38,DSTRT,DSTOP)
+3 SET VPRN=0
SET VPRI="COUNT"
+4 FOR
SET VPRI=$ORDER(@VPRY@(VPRI),-1)
if VPRI<1
QUIT
Begin DoDot:1
+5 SET VPRN=VPRN+1
SET DLIST(VPRN)=+VPRI
End DoDot:1
if VPRN'<DMAX
QUIT
+6 KILL @VPRY
+7 QUIT
+8 ;
ADVDIR ; -- Adv Directive (alerts)
+1 NEW I,AD,TIUD,CNT,STS,NXT
+2 if $GET(DFN)
DO ENCOVER^TIUPP3(DFN)
+3 ; ^TMP = IEN^Acronym^Category Name^Optional Subject^Date/Time^Optional Addendum
+4 ; put AD in Ref D/T order
+5 SET I=0
FOR
SET I=$ORDER(^TMP("TIUPPCV",$JOB,I))
if I<1
QUIT
SET AD=$GET(^(I))
IF $PIECE(AD,U,2)="D"
SET TIUD($PIECE(AD,U,5))=AD
+6 ;no AD's for patient
if '$ORDER(TIUD(0))
QUIT
+7 ; get latest AD, ck if in/active
+8 SET I=+$ORDER(TIUD(""),-1)
SET AD=$GET(TIUD(I))
SET STS="A"
SET NXT=""
+9 ;inactive
IF AD["RESCIND"!($LENGTH($PIECE(AD,U,6)))
Begin DoDot:1
+10 NEW ADD,%DT,X,Y
SET ADD=$PIECE(AD,U,6)
SET STS="I"
+11 SET X=$PIECE(AD,"addendum ",2)
SET X=$PIECE(X,")")
+12 ;end=addendum d/t
IF $LENGTH(X)
SET %DT="TX"
DO ^%DT
if Y>0
SET NXT=Y
End DoDot:1
+13 SET CNT=1
SET DLIST(CNT)=+AD_U_STS_U_NXT
SET NXT=$PIECE(AD,U,5)
+14 ; add remaining AD's as inactive, using next AD's Ref D/T as its end
+15 SET STS="I"
FOR
SET I=$ORDER(TIUD(I),-1)
if I<1
QUIT
SET AD=$GET(TIUD(I))
Begin DoDot:1
+16 SET CNT=CNT+1
SET DLIST(CNT)=+AD_U_STS_U_NXT
+17 SET NXT=$PIECE(AD,U,5)
End DoDot:1
+18 QUIT
+19 ;
LRAP ; -- LR Anatomic Pathology reports [expects LRDFN]
+1 NEW SUB,IDT,VPRN,CTR
SET VPRN=0
+2 DO RR^LR7OR1(DFN,,DSTRT,DSTOP,"AP")
+3 SET SUB=""
FOR
SET SUB=$ORDER(^TMP("LRRR",$JOB,DFN,SUB))
if SUB=""
QUIT
Begin DoDot:1
+4 SET IDT=0
FOR
SET IDT=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,IDT))
if IDT<1
QUIT
IF $ORDER(^(IDT,0))
Begin DoDot:2
+5 ;report in TIU
if $ORDER(^LR(LRDFN,SUB,IDT,.05,0))
QUIT
+6 ;not final results
if '$PIECE($GET(^LR(LRDFN,SUB,IDT,0)),U,11)
QUIT
+7 SET VPRN=VPRN+1
SET DLIST(VPRN)=IDT_","_LRDFN_"~"_SUB
End DoDot:2
if VPRN'<DMAX
QUIT
End DoDot:1
+8 KILL ^TMP("LRRR",$JOB,DFN)
+9 QUIT
+10 ;
LRMI ; -- LR Microbiology reports [expects LRDFN]
+1 NEW IDT,VPRN,CTR
SET VPRN=0
+2 DO RR^LR7OR1(DFN,,DSTRT,DSTOP,"MI")
+3 SET IDT=0
FOR
SET IDT=$ORDER(^TMP("LRRR",$JOB,DFN,"MI",IDT))
if IDT<1
QUIT
IF $ORDER(^(IDT,0))
Begin DoDot:1
+4 ;Q:'$P($G(^LR(LRDFN,"MI",IDT,0)),U,3) ;not final results
+5 ;not final results
if '$$MI1^VPRSDAB(LRDFN,IDT)
QUIT
+6 SET VPRN=VPRN+1
SET DLIST(VPRN)=IDT_","_LRDFN_"~MI"
End DoDot:1
if VPRN'<DMAX
QUIT
+7 KILL ^TMP("LRRR",$JOB,DFN)
+8 QUIT
+9 ;
CONSULTS ; -- Consult/Request Tracking
+1 NEW VPRN,VPRX,GMRCDA,GMRCGRP,GMRCSEX,TITLE
+2 DO OER^GMRCSLM1(DFN,"",DSTRT,DSTOP,"")
SET VPRN=0
+3 FOR
SET VPRN=$ORDER(^TMP("GMRCR",$JOB,"CS",VPRN))
if VPRN<1!(VPRN>DMAX)
QUIT
Begin DoDot:1
+4 SET VPRX=$GET(^TMP("GMRCR",$JOB,"CS",VPRN,0))
if +VPRX<1
QUIT
+5 SET DLIST(VPRN)=+VPRX
End DoDot:1
+6 KILL ^TMP("GMRCR",$JOB,"CS")
+7 QUIT
+8 ;
CPROCS ; -- Clinical Procedures
+1 NEW VPRN,VPRX,I,ID
SET VPRN=0
+2 ;gets ^TMP("MDHSP",$J)
DO MDPS1^VPRDJ03(DFN,DSTRT,DSTOP,DMAX)
+3 SET I=0
FOR
SET I=$ORDER(^TMP("MDHSP",$JOB,I))
if I<1
QUIT
SET VPRX=$GET(^(I))
IF $PIECE(VPRX,U,3)="PR702"
Begin DoDot:1
+4 ;no document yet (so no enc#)
if '$PIECE(VPRX,U,14)
QUIT
+5 SET ^TMP("MDHSP",$JOB,"IEN",+$PIECE(VPRX,U,2))=I
+6 SET VPRN=VPRN+1
SET DLIST(VPRN)=+$PIECE(VPRX,U,2)
End DoDot:1
if VPRN'<DMAX
QUIT
+7 ;K ^TMP("MDHSP",$J)
+8 QUIT
+9 ;
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^VPRSDAVF(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
+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
+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 ;
HFS ; -- V Health Factors, for Social History
+1 NEW ITEM,DATE,DA,VPRN
SET VPRN=0
+2 SET ITEM=0
FOR
SET ITEM=$ORDER(^PXRMINDX(9000010.23,"PI",+$GET(DFN),ITEM))
if ITEM<1
QUIT
IF $$SOCHIST(ITEM)
Begin DoDot:1
+3 SET DATE=DSTRT
FOR
SET DATE=$ORDER(^PXRMINDX(9000010.23,"PI",+$GET(DFN),ITEM,DATE))
if DATE<1!(DATE>DSTOP)
QUIT
Begin DoDot:2
+4 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_U_ITEM
if VPRN'<DMAX
QUIT
End DoDot:2
if VPRN'<DMAX
QUIT
End DoDot:1
if VPRN'<DMAX
QUIT
+5 QUIT
+6 ;
SOCHIST(IEN) ; -- find social history factors
+1 NEW X
SET X=$PIECE($GET(^AUTTHF(+IEN,0)),U)
+2 IF (X["TOBACCO")!(X["SMOK")
QUIT 1
+3 ;I (X["LIVES")!(X["LIVING") Q 1
+4 ;I (X["RELIGIO")!(X["SPIRIT") Q 1
+5 QUIT 0
+6 ;
WVPL ; -- Women's Health Pregnancy Log, for Social History
+1 KILL ^TMP("WVPREGST",$JOB)
+2 DO BASELINE^WVRPCVPR(DFN)
+3 if $DATA(^TMP("WVPREGST",$JOB,"BASELINE"))
SET DLIST(1)=DFN
+4 ;S:$G(^TMP("WVPREGST",$J,"BASELINE","TO TIME"))'<$$FMADD^XLFDT(DT,-14) DLIST(1)=DFN
+5 QUIT
+6 ;
VITALS ; -- GMR Vital Measurements
+1 NEW GMRVSTR,VPRIDT,VPRTYP,ID,VPRN
+2 SET GMRVSTR="BP;T;R;P;HT;WT;CVP;CG;PO2;PN"
+3 SET GMRVSTR(0)=DSTRT_U_DSTOP_U_DMAX_"^1"
+4 DO EN1^GMRVUT0
SET VPRN=0
+5 SET VPRIDT=0
FOR
SET VPRIDT=$ORDER(^UTILITY($JOB,"GMRVD",VPRIDT))
if VPRIDT<1
QUIT
Begin DoDot:1
+6 SET VPRTYP=""
FOR
SET VPRTYP=$ORDER(^UTILITY($JOB,"GMRVD",VPRIDT,VPRTYP))
if VPRTYP=""
QUIT
Begin DoDot:2
+7 SET ID=$ORDER(^UTILITY($JOB,"GMRVD",VPRIDT,VPRTYP,0))
if 'ID
QUIT
+8 SET VPRN=VPRN+1
SET DLIST(VPRN)=ID
+9 SET ^TMP("VPRGMV",$JOB,ID)=$GET(^UTILITY($JOB,"GMRVD",VPRIDT,VPRTYP,ID))
End DoDot:2
End DoDot:1
if VPRN'<DMAX
QUIT
+10 KILL ^UTILITY($JOB,"GMRVD")
+11 QUIT
+12 ;
INS ; -- Insurance
+1 NEW NUM,I,VPRDT,VPRSTS,VPRX
+2 SET VPRSTS=$GET(FILTER("status"),"RB")
SET VPRDT=DT
+3 ;no date if requesting inactive policies
IF VPRSTS["A"
SET VPRDT=""
+4 if $GET(DFN)
SET NUM=$$INSUR^IBBAPI(DFN,VPRDT,VPRSTS,.VPRX,"*")
if NUM<1
QUIT
+5 SET I=0
FOR
SET I=$ORDER(VPRX("IBBAPI","INSUR",I))
if I<1
QUIT
SET DLIST(I)=I
+6 MERGE VPRINS=VPRX("IBBAPI","INSUR")
+7 QUIT
+8 ;
FIM ; -- Functional Independence Measurements
+1 NEW VPRS,VPRN,VPRY,ADM,VPRCNT,RMIMTIME
+2 DO PRM^RMIMRP(.VPRSITE)
if '$ORDER(VPRSITE(1))
QUIT
+3 SET DFN=+$GET(DFN)
if DFN<1
QUIT
+4 SET VPRCNT=0
+5 SET VPRS=1
FOR
SET VPRS=$ORDER(VPRSITE(VPRS))
if VPRS<1
QUIT
Begin DoDot:1
+6 SET VPRN=DFN_U_VPRSITE(VPRS)
+7 DO LC^RMIMRP(.VPRY,VPRN)
if VPRY(1)<1
QUIT
+8 SET VPRN=1
FOR
SET VPRN=$ORDER(VPRY(VPRN))
if VPRN<1
QUIT
Begin DoDot:2
+9 SET ADM=$$DATE($PIECE(VPRY(VPRN),U,4))
if ADM<DSTRT
QUIT
if ADM>DSTOP
QUIT
+10 SET VPRCNT=VPRCNT+1
SET DLIST(VPRCNT)=+VPRY(VPRN)
End DoDot:2
if VPRCNT'<DMAX
QUIT
End DoDot:1
+11 QUIT
+12 ;
DATE(X) ; -- Return internal form of date X
+1 NEW %DT,Y
+2 SET %DT=""
DO ^%DT
if Y<1
SET Y=X
+3 QUIT Y
+4 ;
NOQ ; -- tag for Entities that should not execute a query
+1 QUIT
