VPRDJ0 ;SLC/MKB -- Serve VistA data as JSON cont ;6/25/12 16:11
;;1.0;VIRTUAL PATIENT RECORD;**2,5**;Sep 01, 2011;Build 21
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035 <see VPRDJ0* for others>
;
; All tags expect DFN, VPRSTART, VPRSTOP, VPRMAX, VPRID, VPRTEXT
;
PATIENT ; -- Patient Registration
D DPT1^VPRDJ00
Q
;
PROBLEM ; -- Problem List
I $G(VPRID) D GMPL1^VPRDJ02(VPRID) Q
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)!(VPRI'<VPRMAX) D
. S X=$P(VPRPROB(VPRN),U,6) I X,(X<VPRSTART)!(X>VPRSTOP) Q ;last updated
. S ID=+VPRPROB(VPRN) D GMPL1^VPRDJ02(ID)
Q
;
ALLERGY ; -- Allergies/Adverse Reactions
N GMRAL,ID D EN1^GMRADPT
I 'GMRAL Q ;D NKA^VPRDJ02 Q
I $G(VPRID) D GMRA1^VPRDJ02(VPRID) Q
S ID=0 F S ID=+$O(GMRAL(ID)) Q:ID<1 D GMRA1^VPRDJ02(ID) Q:VPRI'<VPRMAX
Q
;
CONSULT ; -- Consult/Request Tracking
N VPRN,VPRX,ID
D OER^GMRCSLM1(DFN,"",VPRSTART,VPRSTOP,"")
S VPRN=0 F S VPRN=$O(^TMP("GMRCR",$J,"CS",VPRN)) Q:VPRN<1!(VPRN>VPRMAX) S VPRX=$G(^(VPRN,0)) Q:$E(VPRX)="<" D
. I $G(VPRID),VPRID'=+VPRX Q
. D GMRC1^VPRDJ03(+VPRX)
K ^TMP("GMRCR",$J,"CS")
Q
;
VITAL ; -- GMR Vital Measurements
I $L($G(VPRID)) D GMV1^VPRDJ02(VPRID) Q
N GMRVSTR,VPRIDT,VPRTYP,ID
S GMRVSTR="BP;T;R;P;HT;WT;CVP;CG;PO2;PN"
S GMRVSTR(0)=VPRSTART_U_VPRSTOP_U_VPRMAX_"^1"
D EN1^GMRVUT0
S VPRIDT=0 F S VPRIDT=$O(^UTILITY($J,"GMRVD",VPRIDT)) Q:VPRIDT<1 D Q:VPRI'<VPRMAX
. S VPRTYP="" F S VPRTYP=$O(^UTILITY($J,"GMRVD",VPRIDT,VPRTYP)) Q:VPRTYP="" D
.. S ID=$O(^UTILITY($J,"GMRVD",VPRIDT,VPRTYP,0)) D GMV1^VPRDJ02(ID)
K ^UTILITY($J,"GMRVD")
Q
;
LAB ; -- Lab Results
N LRDFN,VPRSUB,VPRIDT,VPRN,VPRP,VPRACC,BEG,END,SUB,ORPK,ID,X
S LRDFN=$G(^DPT(DFN,"LR")),VPRSUB=$G(FILTER("category"))
S BEG=VPRSTART,END=VPRSTOP,VPRID=$G(VPRID),ORPK=""
I $L(VPRID) D ;reset for LR7OR1
. I VPRID S ORPK=VPRID,VPRID=$P(VPRID,";",4,99) Q:VPRID="" ;order
. S VPRSUB=$P(VPRID,";"),VPRIDT=+$P(VPRID,";",2)
. S:VPRIDT (BEG,END)=9999999-VPRIDT
S SUB=VPRSUB I $L(SUB),"CH^MI"'[SUB S SUB="AP"
D RR^LR7OR1(DFN,ORPK,BEG,END,SUB,,,VPRMAX)
S VPRSUB="" F S VPRSUB=$O(^TMP("LRRR",$J,DFN,VPRSUB)) Q:VPRSUB="" D
. S VPRIDT=0 F S VPRIDT=$O(^TMP("LRRR",$J,DFN,VPRSUB,VPRIDT)) Q:VPRIDT<1 I $O(^(VPRIDT,0)) D Q:VPRI'<VPRMAX
.. I VPRSUB="MI" S ID=VPRSUB_";"_VPRIDT D MI^VPRDJ06 Q
.. I VPRSUB'="CH" S ID=VPRSUB_";"_VPRIDT D AP^VPRDJ06 Q
.. D ACC^VPRDJ06 ;get chem accession data
.. S VPRP=0 F S VPRP=$O(^TMP("LRRR",$J,DFN,VPRSUB,VPRIDT,VPRP)) Q:VPRP<1 S X=+$G(^(VPRP)) D
... S VPRN=$$LRDN^LRPXAPIU(X) I $L(VPRID,";")>2,VPRN'=$P(VPRID,";",3) Q
... S ID=VPRSUB_";"_VPRIDT_";"_VPRN D CH1^VPRDJ06
K ^TMP("LRRR",$J),^TMP("LRX",$J)
Q
;
PROCEDUR ; -- Clinical Procedures
N VPRN,VPRX,BEG,END,ID
S BEG=VPRSTART,END=VPRSTOP
I $G(VPRID) D ;reset dates for VPRID only
. N VPRMC,IEN,FILE,X
. S IEN=+VPRID,FILE=+$P(VPRID,"(",2) Q:FILE=702 Q:'FILE
. D MEDLKUP^MCARUTL3(.VPRMC,FILE,IEN)
. S X=$P(VPRMC,U,6) S:X (BEG,END)=X
D MDPS1^VPRDJ03(DFN,BEG,END,VPRMAX) ;gets ^TMP("MDHSP",$J)
S VPRN=0 F S VPRN=$O(^TMP("MDHSP",$J,VPRN)) Q:VPRN<1 S VPRX=$G(^(VPRN)) D
. I $G(VPRID),+VPRID'=+$P(VPRX,U,2) Q ;update 1 procedure
. D MC1^VPRDJ03($G(VPRID)) ;uses VPRX
K ^TMP("MDHSP",$J)
Q
;
OBS ; -- Clinical Observations (CLiO)
N VPRCLIO,VPRN,ID,X
I $L($G(VPRID)) D MDC1^VPRDJ03(VPRID) Q
D QRYPT^VPRDMDC("VPRCLIO",DFN,VPRSTART,VPRSTOP) ;all [verified] observations
S VPRN=0 F S VPRN=$O(VPRCLIO(VPRN)) Q:(VPRN<1)!(VPRI'<VPRMAX) D
. S ID=$G(VPRCLIO(VPRN)) ;GUID
. D MDC1^VPRDJ03(ID)
Q
;
ORDER ; -- Order Entry
N ORLIST,VPRN,DAD,ID,X,X3,X4
I $G(VPRID) S ORLIST=$H D OR1^VPRDJ01(VPRID) G ORQ
D EN^ORQ1(DFN_";DPT(",,6,,VPRSTART,VPRSTOP,,,,1)
S VPRN=0 F S VPRN=$O(^TMP("ORR",$J,ORLIST,VPRN)) Q:VPRN<1 S ID=$G(^(VPRN)) D Q:VPRI'<VPRMAX
. Q:$D(^TMP("ORGOTIT",$J,+ID)) Q:$P(ID,";",2)>1 S ID=+ID ;actions
. S X3=$G(^OR(100,ID,3)),X4=$G(^(4))
. Q:$P(X3,U,3)=13 I X4["P",$P(X3,U,3)=1!($P(X3,U,3)=12) Q ;cancelled
. S DAD=+$P(X3,U,9) I DAD D:'$D(^TMP("ORGOTIT",$J,DAD)) OR1^VPRDJ01(DAD) Q
. D OR1^VPRDJ01(ID)
ORQ ; end
K ^TMP("ORR",$J),^TMP("ORGOTIT",$J)
Q
;
TREATMEN ; -- Nursing Treatments (orders)
N ORLIST,ORDG,VPRN,ID,X,X3,X4
I $G(VPRID) S ORLIST=$H D NTX1^VPRDJ01(VPRID) G TXQ
S ORDG=+$O(^ORD(100.98,"B","NTX",0))
D EN^ORQ1(DFN_";DPT(",ORDG,6,,VPRSTART,VPRSTOP,,,,1)
S VPRN=0 F S VPRN=$O(^TMP("ORR",$J,ORLIST,VPRN)) Q:VPRN<1 S ID=$G(^(VPRN)) D Q:VPRI'<VPRMAX
. Q:$D(^TMP("ORGOTIT",$J,+ID)) Q:$P(ID,";",2)>1 S ID=+ID ;actions
. S X3=$G(^OR(100,ID,3)),X4=$G(^(4))
. Q:$P(X3,U,3)=13 I X4["P",$P(X3,U,3)=1!($P(X3,U,3)=12) Q ;cancelled
. D NTX1^VPRDJ01(ID)
TXQ ; end
K ^TMP("ORR",$J),^TMP("ORGOTIT",$J)
Q
;
MED ; -- Pharmacy
N ORDIALOG I $G(VPRID),$D(^OR(100,+VPRID)) D PS1^VPRDJ05(VPRID) Q ;get 1 order
N TYPE,ORDG,ORVP,ORLIST,VPRN,ORLIST,X3,X4,DAD,ID
S TYPE=$G(FILTER("vaType")) S:$L(TYPE) TYPE=$S(TYPE="N":"NV",TYPE="V":"IV",1:TYPE)_" "
S ORDG=+$O(^ORD(100.98,"B",TYPE_"RX",0)),ORVP=DFN_";DPT("
D EN^ORQ1(ORVP,ORDG,6,,VPRSTART,VPRSTOP)
K ^TMP("VPROR",$J) S VPRN=0
F S VPRN=$O(^TMP("ORR",$J,ORLIST,VPRN)) Q:VPRN<1 S ID=$G(^(VPRN)) D Q:VPRI'<VPRMAX
. Q:$D(^TMP("VPROR",$J,+ID)) Q:$P(ID,";",2)>1 S ID=+ID
. S X3=$G(^OR(100,ID,3)),X4=$G(^(4))
. Q:$P(X3,U,3)=13 I X4["P",$P(X3,U,3)=1!($P(X3,U,3)=12) Q ;cancelled
. S DAD=$P(X3,U,9) I DAD Q:$D(^TMP("VPROR",$J,DAD)) S ID=DAD
. D PS1^VPRDJ05(ID) S ^TMP("VPROR",$J,ID)=""
K ^TMP("VPROR",$J),^TMP("ORR",$J),^TMP("ORGOTIT",$J),^TMP($J,"PSOI")
Q
;
PTF ; -- Patient Treatment File
N VPRIDT,ID
D PTF^VPRDJ09 ;sort ^PXRMINDX into ^TMP("VPRPX",$J,IDT)
I $G(VPRID),VPRID'=+VPRID D PTFA^VPRDJ04A(VPRID) Q
S VPRIDT=0 F S VPRIDT=$O(^TMP("VPRPX",$J,VPRIDT)) Q:VPRIDT<1 D Q:VPRI'<VPRMAX
. S ID="" F S ID=$O(^TMP("VPRPX",$J,VPRIDT,ID)) Q:ID="" D
.. I VPRID=+VPRID,+ID'=+VPRID Q ;single PTF record only
.. D PTF1^VPRDJ04A
K ^TMP("VPRPX",$J)
Q
;
FACTOR D PX^VPRDJ09(9000010.23) Q ; -- PCE Health Factors
IMMUNIZA D PX^VPRDJ09(9000010.11) Q ; -- PCE Immunizations
EXAM D PX^VPRDJ09(9000010.13) Q ; -- PCE Exams
CPT D PX^VPRDJ09(9000010.18) Q ; -- PCE CPT
EDUCATIO D PX^VPRDJ09(9000010.16) Q ; -- PCE Patient Education
POV D PX^VPRDJ09(9000010.07) Q ; -- PCE Purpose of Visit (POV)
SKIN D PX^VPRDJ09(9000010.12) Q ; -- PCE Skin Tests
;
IMAGE ; -- Radiology/Nuclear Medicine
D EN1^RAO7PC1(DFN,VPRSTART,VPRSTOP,VPRMAX_"P")
I $G(VPRID) D RA1^VPRDJ07(VPRID) G IMQ
N ID S ID=""
F S ID=$O(^TMP($J,"RAE1",DFN,ID)) Q:ID="" D RA1^VPRDJ07(ID) Q:VPRI'<+VPRMAX
IMQ ; end
K ^TMP($J,"RAE1")
Q
;
APPOINTM ; -- Scheduling/Appointment Mgt
N VPRX,VPRNUM,VPRDT,X,VPRA,ID
S VPRX(1)=VPRSTART_";"_VPRSTOP,VPRX(4)=DFN,ID=$G(VPRID)
S VPRX("FLDS")="1;2;3;6;9;10;11;13",VPRX("SORT")="P"
I $L(ID) G:$E(ID)="H" DGS^VPRDJ04 D Q
. S VPRDT=$P(ID,";",2),VPRX(1)=$P(ID,";",2)_";"_$P(ID,";",2)
. S VPRX(2)=$P(ID,";",3)
. S VPRNUM=$$SDAPI^SDAMA301(.VPRX)
. D:VPRNUM>0 SDAM1^VPRDJ04
. K ^TMP($J,"SDAMA301",DFN)
; appointments
S VPRX(3)="R;I;NS;NSR;NT" ;no cancelled appt's
S VPRNUM=$$SDAPI^SDAMA301(.VPRX),VPRDT=0
F S VPRDT=$O(^TMP($J,"SDAMA301",DFN,VPRDT)) Q:VPRDT<1 D Q:VPRI'<VPRMAX
. S X=$P($G(^TMP($J,"SDAMA301",DFN,VPRDT)),U,3)
. ;I VPRDT<DT,$P(X,";")'["NS" Q ;no prior kept appt's
. D SDAM1^VPRDJ04
K ^TMP($J,"SDAMA301",DFN)
Q
;
SURGERY ; -- Surgery
I $G(VPRID) D SR1^VPRDJ07(VPRID) Q
Q:'$L($T(LIST^SROESTV))
N SHOWADD S SHOWADD=1 ;to omit leading '+' with note titles
N VPRN,VPRY,ID D LIST^SROESTV(.VPRY,DFN,VPRSTART,VPRSTOP,VPRMAX,1)
S VPRN=0 F S VPRN=$O(@VPRY@(VPRN)) Q:VPRN<1 D
. S ID=+$G(@VPRY@(VPRN)) D:ID SR1^VPRDJ07(ID)
K @VPRY
Q
;
DOCUMENT ; -- Text Integration Utilities
N VPRC,CLS,VPRS,CTXT,VPRY,VPRN,VPRX,ID
I $L($G(VPRID)) D TIU1^VPRDJ08(VPRID) Q
N CLASS,SUBCLASS,STATUS
D SETUP^VPRDJ08 ;define search criteria
F VPRC=1:1:$L(CLASS,U) S CLS=$P(CLASS,U,VPRC) D Q:VPRI'<VPRMAX
. I CLS="CP" D CP^VPRDJ08A(DFN,VPRSTART,VPRSTOP,VPRMAX) Q
. I CLS="RA" D RA^VPRDJ08A(DFN,VPRSTART,VPRSTOP,VPRMAX) Q
. I CLS="LR" D LR^VPRDJ08A(DFN,VPRSTART,VPRSTOP,VPRMAX) Q
. ; TIU document classes, by sig status
. F VPRS=1:1:$L(STATUS,U) S CTXT=$P(STATUS,U,VPRS) D Q:VPRI'<VPRMAX
.. D CONTEXT^TIUSRVLO(.VPRY,CLS,CTXT,DFN,VPRSTART,VPRSTOP,,,,1)
.. S VPRN=0 F S VPRN=$O(@VPRY@(VPRN)) Q:VPRN<1 D Q:VPRI'<VPRMAX
... S VPRX=$G(@VPRY@(VPRN)) Q:'$$MATCH^VPRDJ08(VPRX,CTXT)
... Q:$D(^TMP("VPRD",$J,+VPRX)) ;already included
... D EN1^VPRDJ08(VPRX,CLS)
.. K @VPRY
Q
;
VISIT ; -- Visits
I $L($G(VPRID)) D VSIT1^VPRDJ04(VPRID) Q
N VPRDT,VPRLOC,END,ID
N VPRADMIT S VPRADMIT=+$G(^DPT(DFN,.105)) ;current admission
S END=VPRSTOP I VPRSTOP,VPRSTOP'["." S END=VPRSTOP_".24" ;assume end of day
S VPRDT=END F S VPRDT=$O(^AUPNVSIT("AET",DFN,VPRDT),-1) Q:VPRDT<VPRSTART D Q:VPRI'<VPRMAX
. S VPRLOC=0 F S VPRLOC=$O(^AUPNVSIT("AET",DFN,VPRDT,VPRLOC)) Q:VPRLOC<1 D
.. S ID=0 F S ID=$O(^AUPNVSIT("AET",DFN,VPRDT,VPRLOC,"P",ID)) Q:ID<1 D VSIT1^VPRDJ04(ID)
; kill VPRADMIT in VSIT1 if adm is included, but add unless filtered
I $G(VPRADMIT),VPRMAX'<9999,VPRSTART'>1410102 D VSIT1^VPRDJ04("H"_VPRADMIT)
Q
;
VPR ; -- VPR Patient Objects
D VPR^VPRDJ02($G(TYPE))
Q
;
MH ; -- Mental Health
I $L($T(MH^VPRDJ09M)) D MH^VPRDJ09M
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDJ0 9708 printed Sep 23, 2025@20:20:54 Page 2
VPRDJ0 ;SLC/MKB -- Serve VistA data as JSON cont ;6/25/12 16:11
+1 ;;1.0;VIRTUAL PATIENT RECORD;**2,5**;Sep 01, 2011;Build 21
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DPT 10035 <see VPRDJ0* for others>
+7 ;
+8 ; All tags expect DFN, VPRSTART, VPRSTOP, VPRMAX, VPRID, VPRTEXT
+9 ;
PATIENT ; -- Patient Registration
+1 DO DPT1^VPRDJ00
+2 QUIT
+3 ;
PROBLEM ; -- Problem List
+1 IF $GET(VPRID)
DO GMPL1^VPRDJ02(VPRID)
QUIT
+2 NEW ID,VPRSTS,VPRPROB,VPRN,X
+3 ;default = all problems
SET VPRSTS=$GET(FILTER("status"))
+4 DO LIST^GMPLUTL2(.VPRPROB,DFN,VPRSTS)
+5 SET VPRN=0
FOR
SET VPRN=$ORDER(VPRPROB(VPRN))
if (VPRN<1)!(VPRI'<VPRMAX)
QUIT
Begin DoDot:1
+6 ;last updated
SET X=$PIECE(VPRPROB(VPRN),U,6)
IF X
IF (X<VPRSTART)!(X>VPRSTOP)
QUIT
+7 SET ID=+VPRPROB(VPRN)
DO GMPL1^VPRDJ02(ID)
End DoDot:1
+8 QUIT
+9 ;
ALLERGY ; -- Allergies/Adverse Reactions
+1 NEW GMRAL,ID
DO EN1^GMRADPT
+2 ;D NKA^VPRDJ02 Q
IF 'GMRAL
QUIT
+3 IF $GET(VPRID)
DO GMRA1^VPRDJ02(VPRID)
QUIT
+4 SET ID=0
FOR
SET ID=+$ORDER(GMRAL(ID))
if ID<1
QUIT
DO GMRA1^VPRDJ02(ID)
if VPRI'<VPRMAX
QUIT
+5 QUIT
+6 ;
CONSULT ; -- Consult/Request Tracking
+1 NEW VPRN,VPRX,ID
+2 DO OER^GMRCSLM1(DFN,"",VPRSTART,VPRSTOP,"")
+3 SET VPRN=0
FOR
SET VPRN=$ORDER(^TMP("GMRCR",$JOB,"CS",VPRN))
if VPRN<1!(VPRN>VPRMAX)
QUIT
SET VPRX=$GET(^(VPRN,0))
if $EXTRACT(VPRX)="<"
QUIT
Begin DoDot:1
+4 IF $GET(VPRID)
IF VPRID'=+VPRX
QUIT
+5 DO GMRC1^VPRDJ03(+VPRX)
End DoDot:1
+6 KILL ^TMP("GMRCR",$JOB,"CS")
+7 QUIT
+8 ;
VITAL ; -- GMR Vital Measurements
+1 IF $LENGTH($GET(VPRID))
DO GMV1^VPRDJ02(VPRID)
QUIT
+2 NEW GMRVSTR,VPRIDT,VPRTYP,ID
+3 SET GMRVSTR="BP;T;R;P;HT;WT;CVP;CG;PO2;PN"
+4 SET GMRVSTR(0)=VPRSTART_U_VPRSTOP_U_VPRMAX_"^1"
+5 DO EN1^GMRVUT0
+6 SET VPRIDT=0
FOR
SET VPRIDT=$ORDER(^UTILITY($JOB,"GMRVD",VPRIDT))
if VPRIDT<1
QUIT
Begin DoDot:1
+7 SET VPRTYP=""
FOR
SET VPRTYP=$ORDER(^UTILITY($JOB,"GMRVD",VPRIDT,VPRTYP))
if VPRTYP=""
QUIT
Begin DoDot:2
+8 SET ID=$ORDER(^UTILITY($JOB,"GMRVD",VPRIDT,VPRTYP,0))
DO GMV1^VPRDJ02(ID)
End DoDot:2
End DoDot:1
if VPRI'<VPRMAX
QUIT
+9 KILL ^UTILITY($JOB,"GMRVD")
+10 QUIT
+11 ;
LAB ; -- Lab Results
+1 NEW LRDFN,VPRSUB,VPRIDT,VPRN,VPRP,VPRACC,BEG,END,SUB,ORPK,ID,X
+2 SET LRDFN=$GET(^DPT(DFN,"LR"))
SET VPRSUB=$GET(FILTER("category"))
+3 SET BEG=VPRSTART
SET END=VPRSTOP
SET VPRID=$GET(VPRID)
SET ORPK=""
+4 ;reset for LR7OR1
IF $LENGTH(VPRID)
Begin DoDot:1
+5 ;order
IF VPRID
SET ORPK=VPRID
SET VPRID=$PIECE(VPRID,";",4,99)
if VPRID=""
QUIT
+6 SET VPRSUB=$PIECE(VPRID,";")
SET VPRIDT=+$PIECE(VPRID,";",2)
+7 if VPRIDT
SET (BEG,END)=9999999-VPRIDT
End DoDot:1
+8 SET SUB=VPRSUB
IF $LENGTH(SUB)
IF "CH^MI"'[SUB
SET SUB="AP"
+9 DO RR^LR7OR1(DFN,ORPK,BEG,END,SUB,,,VPRMAX)
+10 SET VPRSUB=""
FOR
SET VPRSUB=$ORDER(^TMP("LRRR",$JOB,DFN,VPRSUB))
if VPRSUB=""
QUIT
Begin DoDot:1
+11 SET VPRIDT=0
FOR
SET VPRIDT=$ORDER(^TMP("LRRR",$JOB,DFN,VPRSUB,VPRIDT))
if VPRIDT<1
QUIT
IF $ORDER(^(VPRIDT,0))
Begin DoDot:2
+12 IF VPRSUB="MI"
SET ID=VPRSUB_";"_VPRIDT
DO MI^VPRDJ06
QUIT
+13 IF VPRSUB'="CH"
SET ID=VPRSUB_";"_VPRIDT
DO AP^VPRDJ06
QUIT
+14 ;get chem accession data
DO ACC^VPRDJ06
+15 SET VPRP=0
FOR
SET VPRP=$ORDER(^TMP("LRRR",$JOB,DFN,VPRSUB,VPRIDT,VPRP))
if VPRP<1
QUIT
SET X=+$GET(^(VPRP))
Begin DoDot:3
+16 SET VPRN=$$LRDN^LRPXAPIU(X)
IF $LENGTH(VPRID,";")>2
IF VPRN'=$PIECE(VPRID,";",3)
QUIT
+17 SET ID=VPRSUB_";"_VPRIDT_";"_VPRN
DO CH1^VPRDJ06
End DoDot:3
End DoDot:2
if VPRI'<VPRMAX
QUIT
End DoDot:1
+18 KILL ^TMP("LRRR",$JOB),^TMP("LRX",$JOB)
+19 QUIT
+20 ;
PROCEDUR ; -- Clinical Procedures
+1 NEW VPRN,VPRX,BEG,END,ID
+2 SET BEG=VPRSTART
SET END=VPRSTOP
+3 ;reset dates for VPRID only
IF $GET(VPRID)
Begin DoDot:1
+4 NEW VPRMC,IEN,FILE,X
+5 SET IEN=+VPRID
SET FILE=+$PIECE(VPRID,"(",2)
if FILE=702
QUIT
if 'FILE
QUIT
+6 DO MEDLKUP^MCARUTL3(.VPRMC,FILE,IEN)
+7 SET X=$PIECE(VPRMC,U,6)
if X
SET (BEG,END)=X
End DoDot:1
+8 ;gets ^TMP("MDHSP",$J)
DO MDPS1^VPRDJ03(DFN,BEG,END,VPRMAX)
+9 SET VPRN=0
FOR
SET VPRN=$ORDER(^TMP("MDHSP",$JOB,VPRN))
if VPRN<1
QUIT
SET VPRX=$GET(^(VPRN))
Begin DoDot:1
+10 ;update 1 procedure
IF $GET(VPRID)
IF +VPRID'=+$PIECE(VPRX,U,2)
QUIT
+11 ;uses VPRX
DO MC1^VPRDJ03($GET(VPRID))
End DoDot:1
+12 KILL ^TMP("MDHSP",$JOB)
+13 QUIT
+14 ;
OBS ; -- Clinical Observations (CLiO)
+1 NEW VPRCLIO,VPRN,ID,X
+2 IF $LENGTH($GET(VPRID))
DO MDC1^VPRDJ03(VPRID)
QUIT
+3 ;all [verified] observations
DO QRYPT^VPRDMDC("VPRCLIO",DFN,VPRSTART,VPRSTOP)
+4 SET VPRN=0
FOR
SET VPRN=$ORDER(VPRCLIO(VPRN))
if (VPRN<1)!(VPRI'<VPRMAX)
QUIT
Begin DoDot:1
+5 ;GUID
SET ID=$GET(VPRCLIO(VPRN))
+6 DO MDC1^VPRDJ03(ID)
End DoDot:1
+7 QUIT
+8 ;
ORDER ; -- Order Entry
+1 NEW ORLIST,VPRN,DAD,ID,X,X3,X4
+2 IF $GET(VPRID)
SET ORLIST=$HOROLOG
DO OR1^VPRDJ01(VPRID)
GOTO ORQ
+3 DO EN^ORQ1(DFN_";DPT(",,6,,VPRSTART,VPRSTOP,,,,1)
+4 SET VPRN=0
FOR
SET VPRN=$ORDER(^TMP("ORR",$JOB,ORLIST,VPRN))
if VPRN<1
QUIT
SET ID=$GET(^(VPRN))
Begin DoDot:1
+5 ;actions
if $DATA(^TMP("ORGOTIT",$JOB,+ID))
QUIT
if $PIECE(ID,";",2)>1
QUIT
SET ID=+ID
+6 SET X3=$GET(^OR(100,ID,3))
SET X4=$GET(^(4))
+7 ;cancelled
if $PIECE(X3,U,3)=13
QUIT
IF X4["P"
IF $PIECE(X3,U,3)=1!($PIECE(X3,U,3)=12)
QUIT
+8 SET DAD=+$PIECE(X3,U,9)
IF DAD
if '$DATA(^TMP("ORGOTIT",$JOB,DAD))
DO OR1^VPRDJ01(DAD)
QUIT
+9 DO OR1^VPRDJ01(ID)
End DoDot:1
if VPRI'<VPRMAX
QUIT
ORQ ; end
+1 KILL ^TMP("ORR",$JOB),^TMP("ORGOTIT",$JOB)
+2 QUIT
+3 ;
TREATMEN ; -- Nursing Treatments (orders)
+1 NEW ORLIST,ORDG,VPRN,ID,X,X3,X4
+2 IF $GET(VPRID)
SET ORLIST=$HOROLOG
DO NTX1^VPRDJ01(VPRID)
GOTO TXQ
+3 SET ORDG=+$ORDER(^ORD(100.98,"B","NTX",0))
+4 DO EN^ORQ1(DFN_";DPT(",ORDG,6,,VPRSTART,VPRSTOP,,,,1)
+5 SET VPRN=0
FOR
SET VPRN=$ORDER(^TMP("ORR",$JOB,ORLIST,VPRN))
if VPRN<1
QUIT
SET ID=$GET(^(VPRN))
Begin DoDot:1
+6 ;actions
if $DATA(^TMP("ORGOTIT",$JOB,+ID))
QUIT
if $PIECE(ID,";",2)>1
QUIT
SET ID=+ID
+7 SET X3=$GET(^OR(100,ID,3))
SET X4=$GET(^(4))
+8 ;cancelled
if $PIECE(X3,U,3)=13
QUIT
IF X4["P"
IF $PIECE(X3,U,3)=1!($PIECE(X3,U,3)=12)
QUIT
+9 DO NTX1^VPRDJ01(ID)
End DoDot:1
if VPRI'<VPRMAX
QUIT
TXQ ; end
+1 KILL ^TMP("ORR",$JOB),^TMP("ORGOTIT",$JOB)
+2 QUIT
+3 ;
MED ; -- Pharmacy
+1 ;get 1 order
NEW ORDIALOG
IF $GET(VPRID)
IF $DATA(^OR(100,+VPRID))
DO PS1^VPRDJ05(VPRID)
QUIT
+2 NEW TYPE,ORDG,ORVP,ORLIST,VPRN,ORLIST,X3,X4,DAD,ID
+3 SET TYPE=$GET(FILTER("vaType"))
if $LENGTH(TYPE)
SET TYPE=$SELECT(TYPE="N":"NV",TYPE="V":"IV",1:TYPE)_" "
+4 SET ORDG=+$ORDER(^ORD(100.98,"B",TYPE_"RX",0))
SET ORVP=DFN_";DPT("
+5 DO EN^ORQ1(ORVP,ORDG,6,,VPRSTART,VPRSTOP)
+6 KILL ^TMP("VPROR",$JOB)
SET VPRN=0
+7 FOR
SET VPRN=$ORDER(^TMP("ORR",$JOB,ORLIST,VPRN))
if VPRN<1
QUIT
SET ID=$GET(^(VPRN))
Begin DoDot:1
+8 if $DATA(^TMP("VPROR",$JOB,+ID))
QUIT
if $PIECE(ID,";",2)>1
QUIT
SET ID=+ID
+9 SET X3=$GET(^OR(100,ID,3))
SET X4=$GET(^(4))
+10 ;cancelled
if $PIECE(X3,U,3)=13
QUIT
IF X4["P"
IF $PIECE(X3,U,3)=1!($PIECE(X3,U,3)=12)
QUIT
+11 SET DAD=$PIECE(X3,U,9)
IF DAD
if $DATA(^TMP("VPROR",$JOB,DAD))
QUIT
SET ID=DAD
+12 DO PS1^VPRDJ05(ID)
SET ^TMP("VPROR",$JOB,ID)=""
End DoDot:1
if VPRI'<VPRMAX
QUIT
+13 KILL ^TMP("VPROR",$JOB),^TMP("ORR",$JOB),^TMP("ORGOTIT",$JOB),^TMP($JOB,"PSOI")
+14 QUIT
+15 ;
PTF ; -- Patient Treatment File
+1 NEW VPRIDT,ID
+2 ;sort ^PXRMINDX into ^TMP("VPRPX",$J,IDT)
DO PTF^VPRDJ09
+3 IF $GET(VPRID)
IF VPRID'=+VPRID
DO PTFA^VPRDJ04A(VPRID)
QUIT
+4 SET VPRIDT=0
FOR
SET VPRIDT=$ORDER(^TMP("VPRPX",$JOB,VPRIDT))
if VPRIDT<1
QUIT
Begin DoDot:1
+5 SET ID=""
FOR
SET ID=$ORDER(^TMP("VPRPX",$JOB,VPRIDT,ID))
if ID=""
QUIT
Begin DoDot:2
+6 ;single PTF record only
IF VPRID=+VPRID
IF +ID'=+VPRID
QUIT
+7 DO PTF1^VPRDJ04A
End DoDot:2
End DoDot:1
if VPRI'<VPRMAX
QUIT
+8 KILL ^TMP("VPRPX",$JOB)
+9 QUIT
+10 ;
FACTOR ; -- PCE Health Factors
DO PX^VPRDJ09(9000010.23)
QUIT
IMMUNIZA ; -- PCE Immunizations
DO PX^VPRDJ09(9000010.11)
QUIT
EXAM ; -- PCE Exams
DO PX^VPRDJ09(9000010.13)
QUIT
CPT ; -- PCE CPT
DO PX^VPRDJ09(9000010.18)
QUIT
EDUCATIO ; -- PCE Patient Education
DO PX^VPRDJ09(9000010.16)
QUIT
POV ; -- PCE Purpose of Visit (POV)
DO PX^VPRDJ09(9000010.07)
QUIT
SKIN ; -- PCE Skin Tests
DO PX^VPRDJ09(9000010.12)
QUIT
+1 ;
IMAGE ; -- Radiology/Nuclear Medicine
+1 DO EN1^RAO7PC1(DFN,VPRSTART,VPRSTOP,VPRMAX_"P")
+2 IF $GET(VPRID)
DO RA1^VPRDJ07(VPRID)
GOTO IMQ
+3 NEW ID
SET ID=""
+4 FOR
SET ID=$ORDER(^TMP($JOB,"RAE1",DFN,ID))
if ID=""
QUIT
DO RA1^VPRDJ07(ID)
if VPRI'<+VPRMAX
QUIT
IMQ ; end
+1 KILL ^TMP($JOB,"RAE1")
+2 QUIT
+3 ;
APPOINTM ; -- Scheduling/Appointment Mgt
+1 NEW VPRX,VPRNUM,VPRDT,X,VPRA,ID
+2 SET VPRX(1)=VPRSTART_";"_VPRSTOP
SET VPRX(4)=DFN
SET ID=$GET(VPRID)
+3 SET VPRX("FLDS")="1;2;3;6;9;10;11;13"
SET VPRX("SORT")="P"
+4 IF $LENGTH(ID)
if $EXTRACT(ID)="H"
GOTO DGS^VPRDJ04
Begin DoDot:1
+5 SET VPRDT=$PIECE(ID,";",2)
SET VPRX(1)=$PIECE(ID,";",2)_";"_$PIECE(ID,";",2)
+6 SET VPRX(2)=$PIECE(ID,";",3)
+7 SET VPRNUM=$$SDAPI^SDAMA301(.VPRX)
+8 if VPRNUM>0
DO SDAM1^VPRDJ04
+9 KILL ^TMP($JOB,"SDAMA301",DFN)
End DoDot:1
QUIT
+10 ; appointments
+11 ;no cancelled appt's
SET VPRX(3)="R;I;NS;NSR;NT"
+12 SET VPRNUM=$$SDAPI^SDAMA301(.VPRX)
SET VPRDT=0
+13 FOR
SET VPRDT=$ORDER(^TMP($JOB,"SDAMA301",DFN,VPRDT))
if VPRDT<1
QUIT
Begin DoDot:1
+14 SET X=$PIECE($GET(^TMP($JOB,"SDAMA301",DFN,VPRDT)),U,3)
+15 ;I VPRDT<DT,$P(X,";")'["NS" Q ;no prior kept appt's
+16 DO SDAM1^VPRDJ04
End DoDot:1
if VPRI'<VPRMAX
QUIT
+17 KILL ^TMP($JOB,"SDAMA301",DFN)
+18 QUIT
+19 ;
SURGERY ; -- Surgery
+1 IF $GET(VPRID)
DO SR1^VPRDJ07(VPRID)
QUIT
+2 if '$LENGTH($TEXT(LIST^SROESTV))
QUIT
+3 ;to omit leading '+' with note titles
NEW SHOWADD
SET SHOWADD=1
+4 NEW VPRN,VPRY,ID
DO LIST^SROESTV(.VPRY,DFN,VPRSTART,VPRSTOP,VPRMAX,1)
+5 SET VPRN=0
FOR
SET VPRN=$ORDER(@VPRY@(VPRN))
if VPRN<1
QUIT
Begin DoDot:1
+6 SET ID=+$GET(@VPRY@(VPRN))
if ID
DO SR1^VPRDJ07(ID)
End DoDot:1
+7 KILL @VPRY
+8 QUIT
+9 ;
DOCUMENT ; -- Text Integration Utilities
+1 NEW VPRC,CLS,VPRS,CTXT,VPRY,VPRN,VPRX,ID
+2 IF $LENGTH($GET(VPRID))
DO TIU1^VPRDJ08(VPRID)
QUIT
+3 NEW CLASS,SUBCLASS,STATUS
+4 ;define search criteria
DO SETUP^VPRDJ08
+5 FOR VPRC=1:1:$LENGTH(CLASS,U)
SET CLS=$PIECE(CLASS,U,VPRC)
Begin DoDot:1
+6 IF CLS="CP"
DO CP^VPRDJ08A(DFN,VPRSTART,VPRSTOP,VPRMAX)
QUIT
+7 IF CLS="RA"
DO RA^VPRDJ08A(DFN,VPRSTART,VPRSTOP,VPRMAX)
QUIT
+8 IF CLS="LR"
DO LR^VPRDJ08A(DFN,VPRSTART,VPRSTOP,VPRMAX)
QUIT
+9 ; TIU document classes, by sig status
+10 FOR VPRS=1:1:$LENGTH(STATUS,U)
SET CTXT=$PIECE(STATUS,U,VPRS)
Begin DoDot:2
+11 DO CONTEXT^TIUSRVLO(.VPRY,CLS,CTXT,DFN,VPRSTART,VPRSTOP,,,,1)
+12 SET VPRN=0
FOR
SET VPRN=$ORDER(@VPRY@(VPRN))
if VPRN<1
QUIT
Begin DoDot:3
+13 SET VPRX=$GET(@VPRY@(VPRN))
if '$$MATCH^VPRDJ08(VPRX,CTXT)
QUIT
+14 ;already included
if $DATA(^TMP("VPRD",$JOB,+VPRX))
QUIT
+15 DO EN1^VPRDJ08(VPRX,CLS)
End DoDot:3
if VPRI'<VPRMAX
QUIT
+16 KILL @VPRY
End DoDot:2
if VPRI'<VPRMAX
QUIT
End DoDot:1
if VPRI'<VPRMAX
QUIT
+17 QUIT
+18 ;
VISIT ; -- Visits
+1 IF $LENGTH($GET(VPRID))
DO VSIT1^VPRDJ04(VPRID)
QUIT
+2 NEW VPRDT,VPRLOC,END,ID
+3 ;current admission
NEW VPRADMIT
SET VPRADMIT=+$GET(^DPT(DFN,.105))
+4 ;assume end of day
SET END=VPRSTOP
IF VPRSTOP
IF VPRSTOP'["."
SET END=VPRSTOP_".24"
+5 SET VPRDT=END
FOR
SET VPRDT=$ORDER(^AUPNVSIT("AET",DFN,VPRDT),-1)
if VPRDT<VPRSTART
QUIT
Begin DoDot:1
+6 SET VPRLOC=0
FOR
SET VPRLOC=$ORDER(^AUPNVSIT("AET",DFN,VPRDT,VPRLOC))
if VPRLOC<1
QUIT
Begin DoDot:2
+7 SET ID=0
FOR
SET ID=$ORDER(^AUPNVSIT("AET",DFN,VPRDT,VPRLOC,"P",ID))
if ID<1
QUIT
DO VSIT1^VPRDJ04(ID)
End DoDot:2
End DoDot:1
if VPRI'<VPRMAX
QUIT
+8 ; kill VPRADMIT in VSIT1 if adm is included, but add unless filtered
+9 IF $GET(VPRADMIT)
IF VPRMAX'<9999
IF VPRSTART'>1410102
DO VSIT1^VPRDJ04("H"_VPRADMIT)
+10 QUIT
+11 ;
VPR ; -- VPR Patient Objects
+1 DO VPR^VPRDJ02($GET(TYPE))
+2 QUIT
+3 ;
MH ; -- Mental Health
+1 IF $LENGTH($TEXT(MH^VPRDJ09M))
DO MH^VPRDJ09M
+2 QUIT
