HMPDJ0 ;SLC/MKB,ASMR/JD,PB,CPC -- Serve VistA data as JSON cont ; 07/13/16 04:45pm
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2,3**;Sep 01, 2011;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035 <see HMPDJ0* for others>
; EN^ORQ1 3154
; SDAMA301 4433
;
; All tags expect DFN, HMPSTART, HMPSTOP, HMPMAX, HMPID, HMPTEXT
Q
;
PATIENT ; -- Patient Registration
D DPT1^HMPDJ00
Q
;
PROBLEM ; -- Problem List
I $G(HMPID) D GMPL1^HMPDJ02(HMPID) Q
N ID,HMPSTS,HMPPROB,HMPN,X,POVLST
S HMPSTS=$G(FILTER("status")) ;default = all problems
D LIST^GMPLUTL2(.HMPPROB,DFN,HMPSTS)
D DIAGLIST^HMPDJ02(.POVLST,DFN)
S HMPN=0 F S HMPN=$O(HMPPROB(HMPN)) Q:(HMPN<1)!(HMPI'<HMPMAX) D
. S X=$P(HMPPROB(HMPN),U,6) I X,(X<HMPSTART)!(X>HMPSTOP) Q ;last updated
. S ID=+HMPPROB(HMPN) D GMPL1^HMPDJ02(ID,.POVLST)
Q
;
ALLERGY ; -- Allergies/Adverse Reactions
N GMRAL,ID D EN1^GMRADPT
; This IF statement was disabled to prevent getting "deletes" in the
; JSON during a fetch if ALL allergies for a given patient have been marked
; as "entered in error". US6021
;I 'GMRAL Q ;D NKA^HMPDJ02 Q
I $G(HMPID) D GMRA1^HMPDJ02(HMPID) Q
S ID=0 F S ID=+$O(GMRAL(ID)) Q:ID<1 D GMRA1^HMPDJ02(ID) Q:HMPI'<HMPMAX
Q
;
CONSULT ; -- Consult/Request Tracking
N HMPN,HMPX,ID
D OER^GMRCSLM1(DFN,"",HMPSTART,HMPSTOP,"")
S HMPN=0 F S HMPN=$O(^TMP("GMRCR",$J,"CS",HMPN)) Q:HMPN<1!(HMPN>HMPMAX) S HMPX=$G(^(HMPN,0)) Q:$E(HMPX)="<" D
. I $G(HMPID),HMPID'=+HMPX Q
. D GMRC1^HMPDJ03(+HMPX)
K ^TMP("GMRCR",$J,"CS")
Q
;
VITAL ; -- GMR Vital Measurements
I $L($G(HMPID)) D GMV1^HMPDJ02(HMPID) Q
N GMRVSTR,HMPIDT,HMPTYP,ID
S GMRVSTR="BP;T;R;P;HT;WT;CVP;CG;PO2;PN"
S GMRVSTR(0)=HMPSTART_U_HMPSTOP_U_HMPMAX_"^1"
D EN1^GMRVUT0
S HMPIDT=0 F S HMPIDT=$O(^UTILITY($J,"GMRVD",HMPIDT)) Q:HMPIDT<1 D Q:HMPI'<HMPMAX
. S HMPTYP="" F S HMPTYP=$O(^UTILITY($J,"GMRVD",HMPIDT,HMPTYP)) Q:HMPTYP="" D
.. S ID=$O(^UTILITY($J,"GMRVD",HMPIDT,HMPTYP,0)) D GMV1^HMPDJ02(ID)
K ^UTILITY($J,"GMRVD")
Q
;
LAB ; -- Lab Results
N LRDFN,LRID,HMPSUB,HMPIDT,HMPN,HMPP,HMPACC,BEG,END,SUB,ORPK,ID,X
S LRDFN=$$LRDFN^HMPXGLAB(DFN),HMPSUB=$G(FILTER("category")) ;DE2818, (#63) LABORATORY REFERENCE
S BEG=HMPSTART,END=HMPSTOP,LRID=$G(HMPID),ORPK=""
I $L(LRID) D ;reset for LR7OR1
. I LRID S ORPK=LRID,LRID=$P(LRID,";",4,99) Q:LRID="" ;order
. S HMPSUB=$P(LRID,";"),HMPIDT=+$P(LRID,";",2)
. S:HMPIDT (BEG,END)=9999999-HMPIDT
S SUB=HMPSUB I $L(SUB),"CH^MI"'[SUB S SUB="AP"
D RR^LR7OR1(DFN,ORPK,BEG,END,SUB,,,HMPMAX) ; ICR 2503, DE2818
S HMPSUB="" F S HMPSUB=$O(^TMP("LRRR",$J,DFN,HMPSUB)) Q:HMPSUB="" D
. S HMPIDT=0 F S HMPIDT=$O(^TMP("LRRR",$J,DFN,HMPSUB,HMPIDT)) Q:HMPIDT<1 I $O(^(HMPIDT,0)) D Q:HMPI'<HMPMAX
.. I HMPSUB="MI" S ID=HMPSUB_";"_HMPIDT D MI^HMPDJ06 Q
.. I HMPSUB'="CH" S ID=HMPSUB_";"_HMPIDT D AP^HMPDJ06 Q
.. D ACC^HMPDJ06 ;get chem accession data
.. S HMPP=0 F S HMPP=$O(^TMP("LRRR",$J,DFN,HMPSUB,HMPIDT,HMPP)) Q:HMPP<1 S X=+$G(^(HMPP)) D
... S HMPN=$$LRDN^LRPXAPIU(X) I $L(LRID,";")>2,HMPN'=$P(LRID,";",3) Q
... S ID=HMPSUB_";"_HMPIDT_";"_HMPN D CH1^HMPDJ06
K ^TMP("LRRR",$J),^TMP("LRX",$J)
Q
;
PROCEDUR ; -- Clinical Procedures
N HMPN,HMPX,BEG,END,ID
S BEG=HMPSTART,END=HMPSTOP
I $G(HMPID) D ;reset dates for HMPID only
. N HMPMC,IEN,FILE,X
. S IEN=+HMPID,FILE=+$P(HMPID,"(",2) Q:FILE=702 Q:'FILE
. D MEDLKUP^MCARUTL3(.HMPMC,FILE,IEN)
. S X=$P(HMPMC,U,6) S:X (BEG,END)=X
D MDPS1^HMPDJ03(DFN,BEG,END,HMPMAX) ;gets ^TMP("MDHSP",$J)
S HMPN=0 F S HMPN=$O(^TMP("MDHSP",$J,HMPN)) Q:HMPN<1 S HMPX=$G(^(HMPN)) D
. I $G(HMPID),+HMPID'=+$P(HMPX,U,2) Q ;update 1 procedure
. D MC1^HMPDJ03($G(HMPID)) ;uses HMPX
K ^TMP("MDHSP",$J)
Q
;
OBS ; -- Clinical Observations (CLiO)
N HMPCLIO,HMPN,ID,X
I $L($G(HMPID)) D MDC1^HMPDJ03(HMPID) Q
D QRYPT^HMPDMDC("HMPCLIO",DFN,HMPSTART,HMPSTOP) ;all [verified] observations
S HMPN=0 F S HMPN=$O(HMPCLIO(HMPN)) Q:(HMPN<1)!(HMPI'<HMPMAX) D
. S ID=$G(HMPCLIO(HMPN)) ;GUID
. D MDC1^HMPDJ03(ID)
Q
;
ORDER ; -- Order Entry
N DAD,HMPN,HMPORDR,ID,ORLIST,X ; DE2818, added HMPORDR, removed X3,X4
I $G(HMPID) S ORLIST=$H D OR1^HMPDJ01(HMPID) G ORQ
; changed FLG to 1 to get all orders including pending. JD - 1/20/16 - US11951
D EN^ORQ1(DFN_";DPT(",,1,,HMPSTART,HMPSTOP,,,,1) ; DBIA 3154
S HMPN=0 F S HMPN=$O(^TMP("ORR",$J,ORLIST,HMPN)) Q:HMPN<1 S ID=$G(^(HMPN)),ID=+ID D Q:HMPI'<HMPMAX
. ;DE2818, begin logic change
. K HMPORDR D ORDINFO(.HMPORDR,ID) ; kill it for each iteration
. ; (#33) PACKAGE REFERENCE
. ; (# 5) STATUS: 13=CANCELLED, 12=DISCONTINUED/EDIT, 1=DISCONTINUED
. Q:$G(HMPORDR(100,ID,5,"I"))=13 I $G(HMPORDR(100,ID,33,"I"))["P",($G(HMPORDR(100,ID,5,"I"))=12)!($G(HMPORDR(100,ID,5,"I"))=1) Q
. ; Get Parent order if we don't already have it
. ; Also, add the child order to the returned list
. S DAD=$G(HMPORDR(100,ID,36,"I")) ;(#36) PARENT
. I DAD D:'$D(^TMP("ORGOTIT",$J,DAD)) OR1^HMPDJ01(DAD)
. ;DE2818, end logic change
. D OR1^HMPDJ01(ID)
ORQ ; end
K ^TMP("ORR",$J),^TMP("ORGOTIT",$J)
Q
;
TREATMEN ; -- Nursing Treatments (orders)
N HMPN,HMPORDR,ID,ORDG,ORLIST,X ;DE2818, added HMPORDR, removed X3,X4
I $G(HMPID) S ORLIST=$H D NTX1^HMPDJ01(HMPID) G TXQ
;DE2818, ***replacement for ^ORD reference needed below***
S ORDG=+$O(^ORD(100.98,"B","NTX",0))
D EN^ORQ1(DFN_";DPT(",ORDG,6,,HMPSTART,HMPSTOP,,,,1)
S HMPN=0 F S HMPN=$O(^TMP("ORR",$J,ORLIST,HMPN)) Q:HMPN<1 S ID=$G(^(HMPN)) D Q:HMPI'<HMPMAX
. Q:$D(^TMP("ORGOTIT",$J,+ID)) Q:$P(ID,";",2)>1 S ID=+ID ;actions
. ;DE2818, begin logic change
. K HMPORDR D ORDINFO(.HMPORDR,ID) ; kill it for each iteration
. ;(#33) PACKAGE REFERENCE,(#5) STATUS: 13=CANCELLED, 12=DISCONTINUED/EDIT, 1=DISCONTINUED
. Q:$G(HMPORDR(100,ID,5,"I"))=13 I $G(HMPORDR(100,ID,33,"I"))["P",($G(HMPORDR(100,ID,5,"I"))=12)!($G(HMPORDR(100,ID,5,"I"))=1) Q
. ;DE2818, end logic change
. D NTX1^HMPDJ01(ID)
TXQ ; end
K ^TMP("ORR",$J),^TMP("ORGOTIT",$J)
Q
;
MED ; -- Pharmacy
;DE2818, removed reference to ^OR(100,HMPID) below
N ORDIALOG I $G(HMPID),$$GET1^DIQ(100,+HMPID_",",.01)]"" D PS1^HMPDJ05(HMPID) Q ;get 1 order
N DAD,HMPN,HMPORDR,ID,ORDG,ORLIST,ORVP,TYPE ;DE2818, added HMPORDR, removed extra ORLIST and X3,X4
S TYPE=$G(FILTER("vaType")) S:$L(TYPE) TYPE=$S(TYPE="N":"NV",TYPE="V":"IV",1:TYPE)_" "
;DE2818, ***replacement for ^ORD reference needed below***
S ORDG=$O(^ORD(100.98,"B",TYPE_"RX",0)),ORVP=DFN_";DPT(" ;CPC removed + 10/30/15 DE2434
;If RX group not found, and not overridden by specific type then try PHARMACY CPC 10/30/15 DE2434
I ORDG="" S ORDG=0 I TYPE="" S ORDG=+$O(^ORD(100.98,"B","PHARMACY",0)) ;CPC 10/30/15 DE2434
D EN^ORQ1(ORVP,ORDG,6,,HMPSTART,HMPSTOP)
K ^TMP("HMPOR",$J) S HMPN=0
F S HMPN=$O(^TMP("ORR",$J,ORLIST,HMPN)) Q:HMPN<1 S ID=$G(^(HMPN)),ID=+ID D Q:HMPI'<HMPMAX
. ;DE2818, begin logic change
. K HMPORDR D ORDINFO(.HMPORDR,ID) ; kill it for each iteration
. ;(#33) PACKAGE REFERENCE,(#5) STATUS: 13=CANCELLED, 12=DISCONTINUED/EDIT, 1=DISCONTINUED
. Q:$G(HMPORDR(100,ID,5,"I"))=13 I $G(HMPORDR(100,ID,33,"I"))["P",($G(HMPORDR(100,ID,5,"I"))=12)!($G(HMPORDR(100,ID,5,"I"))=1) Q
. S DAD=$G(HMPORDR(100,ID,36,"I")) ;(#36) PARENT
. I DAD D:'$D(^TMP("HMPOR",$J,DAD)) PS1^HMPDJ05(DAD)
. ;DE2818, end logic change
. D PS1^HMPDJ05(ID) ;DE5156 ensure parent added as well as children
K ^TMP("HMPOR",$J),^TMP("ORR",$J),^TMP("ORGOTIT",$J),^TMP($J,"PSOI")
Q
;
PTF ; -- Patient Treatment File
;Purpose - Main Patient Treatment File (PTF) RPC
;
;Called by - PTF RPC
;
;Assumptions - Expects variables DFN, HMPSTART, HMPSTOP, HMPMAX
;
;Modification History -
;US5630 (TW) - Namespaced variables and enhanced newing
;
N HMPRDT,HMPX,HMPAPI,HMPLID
K ^TMP("HMPPX",$J)
;
I $G(HMPID),HMPID'=+HMPID D PTFA^HMPDJ04A(HMPID) Q ; If HMPID and dx type, process and quit
;
I $G(HMPID) D Q:'$D(^TMP("HMPPX",$J)) ; If HMPID only, set one ^TMP("HMPPX") entry
. S HMPRDT=9999999
. D RPC^DGPTFAPI(.HMPAPI,HMPID)
. S HMPX=$P($G(HMPAPI(1)),U,3)
. I $L(HMPX) S ^TMP("HMPPX",$J,HMPRDT,HMPID_";70;DXLS")=HMPX_U
. F HMPAPI=1:1:9 S HMPX=$P($G(HMPY(2)),U,HMPAPI) I $L(HMPX) S ^TMP("HMPPX",$J,HMPRDT,HMPID_";70;D SD"_HMPAPI)=HMPX_U_$G(DISDAT)
;
I '$G(HMPID) D PTF^HMPDJ09 ; If no HMPID, set up ^TMP("HMPPX") for all dx
;
;Loop through ^TMP("HMPPX",$J) and do PTF1^HMPDJ04A to set PTF array, ^TMP
S HMPRDT="" F S HMPRDT=$O(^TMP("HMPPX",$J,HMPRDT)) Q:HMPRDT="" D
. S HMPLID="" F S HMPLID=$O(^TMP("HMPPX",$J,HMPRDT,HMPLID)) Q:HMPLID=""!(HMPI'<HMPMAX) D
.. D PTF1^HMPDJ04A
K ^TMP("HMPPX",$J)
Q
;
FACTOR D PX^HMPDJ09(9000010.23) Q ; -- PCE Health Factors
IMMUNIZA D PX^HMPDJ09(9000010.11) Q ; -- PCE Immunizations
EXAM D PX^HMPDJ09(9000010.13) Q ; -- PCE Exams
CPT D PX^HMPDJ09(9000010.18) Q ; -- PCE CPT
EDUCATIO D PX^HMPDJ09(9000010.16) Q ; -- PCE Patient Education
POV D PX^HMPDJ09(9000010.07) Q ; -- PCE Purpose of Visit (POV)
SKIN D PX^HMPDJ09(9000010.12) Q ; -- PCE Skin Tests
;
IMAGE ; -- Radiology/Nuclear Medicine
D EN1^RAO7PC1(DFN,HMPSTART,HMPSTOP,HMPMAX_"P")
I $G(HMPID) D RA1^HMPDJ07(HMPID) G IMQ
N ID S ID=""
F S ID=$O(^TMP($J,"RAE1",DFN,ID)) Q:ID="" D RA1^HMPDJ07(ID) Q:HMPI'<+HMPMAX
IMQ ; end
K ^TMP($J,"RAE1")
Q
;
APPOINTM ; -- Scheduling/Appointment Mgt
N HMPX,HMPNUM,HMPDT,X,HMPA,ID
S HMPX(1)=HMPSTART_";"_HMPSTOP,HMPX(4)=DFN,ID=$G(HMPID)
S HMPX("FLDS")="1;2;3;6;9;10;11;13;22",HMPX("SORT")="P" ;DE4469 - PB - Apr 26, 2016 added field 22 to the list of fields to be pulled.
I $L(ID) G:$E(ID)="H" DGS^HMPDJ04 D Q
. S HMPDT=$P(ID,";",2),HMPX(1)=$P(ID,";",2)_";"_$P(ID,";",2)
. S HMPX(2)=$P(ID,";",3)
. S HMPNUM=$$SDAPI^SDAMA301(.HMPX)
. D:HMPNUM>0 SDAM1^HMPDJ04
. K ^TMP($J,"SDAMA301",DFN)
; appointments
S HMPX(3)="R;I;NS;NSR;NT" ;no cancelled appt's
S HMPNUM=$$SDAPI^SDAMA301(.HMPX),HMPDT=0
F S HMPDT=$O(^TMP($J,"SDAMA301",DFN,HMPDT)) Q:HMPDT<1 D Q:HMPI'<HMPMAX
. S X=$P($G(^TMP($J,"SDAMA301",DFN,HMPDT)),U,3)
. ;I HMPDT<DT,$P(X,";")'["NS" Q ;no prior kept appt's
. D SDAM1^HMPDJ04
K ^TMP($J,"SDAMA301",DFN)
Q
;
SURGERY ; -- Surgery
I $G(HMPID) D SR1^HMPDJ07(HMPID) Q
Q:'$L($T(LIST^SROESTV))
N SHOWADD S SHOWADD=1 ;to omit leading '+' with note titles
N HMPN,HMPY,ID D LIST^SROESTV(.HMPY,DFN,HMPSTART,HMPSTOP,HMPMAX,1)
S HMPN=0 F S HMPN=$O(@HMPY@(HMPN)) Q:HMPN<1 D
. S ID=+$G(@HMPY@(HMPN)) D:ID SR1^HMPDJ07(ID)
K @HMPY
Q
;
DOCUMENT ; -- Text Integration Utilities
N HMPC,CLS,HMPS,CTXT,HMPY,HMPN,HMPX,ID
I $L($G(HMPID)) D TIU1^HMPDJ08(HMPID) Q
N CLASS,SUBCLASS,STATUS
D SETUP^HMPDJ08 ;define search criteria
F HMPC=1:1:$L(CLASS,U) S CLS=$P(CLASS,U,HMPC) D Q:HMPI'<HMPMAX
. I CLS="CP" D CP^HMPDJ08A(DFN,HMPSTART,HMPSTOP,HMPMAX) Q
. I CLS="RA" D RA^HMPDJ08A(DFN,HMPSTART,HMPSTOP,HMPMAX) Q
. I CLS="LR" D LR^HMPDJ08A(DFN,HMPSTART,HMPSTOP,HMPMAX) Q
. ; TIU document classes, by sig status
. F HMPS=1:1:$L(STATUS,U) S CTXT=$P(STATUS,U,HMPS) D Q:HMPI'<HMPMAX
.. ;I $L($G(HMPBATCH)) D GET^TIUHMP(.HMPY,DFN,CLS,HMPSTART,HMPSTOP) I 1 ; <<<< 12.3
.. I $L($G(HMPBATCH)) D GET^TIUVPR(.HMPY,DFN,CLS,HMPSTART,HMPSTOP) I 1 ; <<<< 12.3
.. E D CONTEXT^TIUSRVLO(.HMPY,CLS,CTXT,DFN,HMPSTART,HMPSTOP,,HMPMAX,,1)
.. S HMPN=0 F S HMPN=$O(@HMPY@(HMPN)) Q:HMPN<1 D Q:HMPI'<HMPMAX
... S HMPX=$G(@HMPY@(HMPN)) ;Q:'$$MATCH^HMPDJ08(HMPX,CTXT)
... Q:$D(^TMP("HMPD",$J,+HMPX)) ;already included
... D EN1^HMPDJ08(HMPX,CLS)
.. K @HMPY
Q
;
VISIT ; -- Visits
I $L($G(HMPID)) D VSIT1^HMPDJ04(HMPID) Q
N BEG,END,HMPADMIT,HMPDEMOG,HMPIDT,ID ;DE2818, added HMPDEMOG
D TOP^HMPXGDPT("HMPDEMOG",DFN,.105,"I") ;DE2818, (.105) CURRENT ADMISSION
S HMPADMIT=+$G(HMPDEMOG(2,DFN,.105,"I")) ;DE2818
S BEG=HMPSTART,END=HMPSTOP D IDT^HMPDVSIT ;invert dates
;DE2818 ***ICR 2028 needed for ^AUPNVSIT references below***
S HMPIDT=BEG F S HMPIDT=$O(^AUPNVSIT("AA",DFN,HMPIDT)) Q:HMPIDT<1!(HMPIDT>END) D Q:HMPI'<HMPMAX
. S ID=0 F S ID=$O(^AUPNVSIT("AA",DFN,HMPIDT,ID)) Q:ID<1 D VSIT1^HMPDJ04(ID)
; kill HMPADMIT in VSIT1 if adm is included, but add unless filtered
I $G(HMPADMIT),HMPMAX'<9999,HMPSTART'>1410102 D VSIT1^HMPDJ04("H"_HMPADMIT)
Q
;I HMPSTOP,HMPSTOP'["." S END=HMPSTOP_".24" ;assume end of day
;S HMPDT=END F S HMPDT=$O(^AUPNVSIT("AET",DFN,HMPDT),-1) Q:HMPDT<HMPSTART D Q:HMPI'<HMPMAX
;. S HMPLOC=0 F S HMPLOC=$O(^AUPNVSIT("AET",DFN,HMPDT,HMPLOC)) Q:HMPLOC<1 D
;.. S ID=0 F S ID=$O(^AUPNVSIT("AET",DFN,HMPDT,HMPLOC,"P",ID)) Q:ID<1 D VSIT1^HMPDJ04(ID)
;
HMP ; -- HMP Patient Objects
D HMP^HMPDJ02($G(TYPE))
Q
;
MH ; -- Mental Health
I $L($T(MH^HMPDJ09M)) D MH^HMPDJ09M
Q
;
ERRQ ; -- Quit for error handling
Q
;
;new subroutine for DE2818
ORDINFO(ORRSLT,ORIEN) ; ORDER file (#100), ORRSLT passed by reference
; all data returned in internal format
;
; fields on ^OR(100,D0,0)
;(#.01) ORDER #
;(#.02) OBJECT OF ORDER
;
; fields on ^OR(100,D0,3)
;(#5) STATUS
;(#7) ITEM ORDERED
;(#8) VEILED
;(#8.1) TYPE
;(#9) REPLACED ORDER
;(#9.1) REPLACEMENT ORDER
;(#30) CURRENT ACTION
;(#31) DATE OF LAST ACTIVITY
;(#32) GRACE DAYS BEFORE PURGE
;(#36) PARENT
;(#35) ALERT ON RESULTS
;
; field on ^OR(100,D0,4)
;(#33) PACKAGE REFERENCE
;
Q:'($G(ORIEN)>0) ; IEN required
D TOP^HMPXGORD("ORRSLT",ORIEN,".01;.02;5;7;8;8.1;9;9.1;30;31;32;33;35;36","I")
;
Q
;end DE2818
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDJ0 13733 printed Nov 22, 2024@17:03:22 Page 2
HMPDJ0 ;SLC/MKB,ASMR/JD,PB,CPC -- Serve VistA data as JSON cont ; 07/13/16 04:45pm
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**2,3**;Sep 01, 2011;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DPT 10035 <see HMPDJ0* for others>
+7 ; EN^ORQ1 3154
+8 ; SDAMA301 4433
+9 ;
+10 ; All tags expect DFN, HMPSTART, HMPSTOP, HMPMAX, HMPID, HMPTEXT
+11 QUIT
+12 ;
PATIENT ; -- Patient Registration
+1 DO DPT1^HMPDJ00
+2 QUIT
+3 ;
PROBLEM ; -- Problem List
+1 IF $GET(HMPID)
DO GMPL1^HMPDJ02(HMPID)
QUIT
+2 NEW ID,HMPSTS,HMPPROB,HMPN,X,POVLST
+3 ;default = all problems
SET HMPSTS=$GET(FILTER("status"))
+4 DO LIST^GMPLUTL2(.HMPPROB,DFN,HMPSTS)
+5 DO DIAGLIST^HMPDJ02(.POVLST,DFN)
+6 SET HMPN=0
FOR
SET HMPN=$ORDER(HMPPROB(HMPN))
if (HMPN<1)!(HMPI'<HMPMAX)
QUIT
Begin DoDot:1
+7 ;last updated
SET X=$PIECE(HMPPROB(HMPN),U,6)
IF X
IF (X<HMPSTART)!(X>HMPSTOP)
QUIT
+8 SET ID=+HMPPROB(HMPN)
DO GMPL1^HMPDJ02(ID,.POVLST)
End DoDot:1
+9 QUIT
+10 ;
ALLERGY ; -- Allergies/Adverse Reactions
+1 NEW GMRAL,ID
DO EN1^GMRADPT
+2 ; This IF statement was disabled to prevent getting "deletes" in the
+3 ; JSON during a fetch if ALL allergies for a given patient have been marked
+4 ; as "entered in error". US6021
+5 ;I 'GMRAL Q ;D NKA^HMPDJ02 Q
+6 IF $GET(HMPID)
DO GMRA1^HMPDJ02(HMPID)
QUIT
+7 SET ID=0
FOR
SET ID=+$ORDER(GMRAL(ID))
if ID<1
QUIT
DO GMRA1^HMPDJ02(ID)
if HMPI'<HMPMAX
QUIT
+8 QUIT
+9 ;
CONSULT ; -- Consult/Request Tracking
+1 NEW HMPN,HMPX,ID
+2 DO OER^GMRCSLM1(DFN,"",HMPSTART,HMPSTOP,"")
+3 SET HMPN=0
FOR
SET HMPN=$ORDER(^TMP("GMRCR",$JOB,"CS",HMPN))
if HMPN<1!(HMPN>HMPMAX)
QUIT
SET HMPX=$GET(^(HMPN,0))
if $EXTRACT(HMPX)="<"
QUIT
Begin DoDot:1
+4 IF $GET(HMPID)
IF HMPID'=+HMPX
QUIT
+5 DO GMRC1^HMPDJ03(+HMPX)
End DoDot:1
+6 KILL ^TMP("GMRCR",$JOB,"CS")
+7 QUIT
+8 ;
VITAL ; -- GMR Vital Measurements
+1 IF $LENGTH($GET(HMPID))
DO GMV1^HMPDJ02(HMPID)
QUIT
+2 NEW GMRVSTR,HMPIDT,HMPTYP,ID
+3 SET GMRVSTR="BP;T;R;P;HT;WT;CVP;CG;PO2;PN"
+4 SET GMRVSTR(0)=HMPSTART_U_HMPSTOP_U_HMPMAX_"^1"
+5 DO EN1^GMRVUT0
+6 SET HMPIDT=0
FOR
SET HMPIDT=$ORDER(^UTILITY($JOB,"GMRVD",HMPIDT))
if HMPIDT<1
QUIT
Begin DoDot:1
+7 SET HMPTYP=""
FOR
SET HMPTYP=$ORDER(^UTILITY($JOB,"GMRVD",HMPIDT,HMPTYP))
if HMPTYP=""
QUIT
Begin DoDot:2
+8 SET ID=$ORDER(^UTILITY($JOB,"GMRVD",HMPIDT,HMPTYP,0))
DO GMV1^HMPDJ02(ID)
End DoDot:2
End DoDot:1
if HMPI'<HMPMAX
QUIT
+9 KILL ^UTILITY($JOB,"GMRVD")
+10 QUIT
+11 ;
LAB ; -- Lab Results
+1 NEW LRDFN,LRID,HMPSUB,HMPIDT,HMPN,HMPP,HMPACC,BEG,END,SUB,ORPK,ID,X
+2 ;DE2818, (#63) LABORATORY REFERENCE
SET LRDFN=$$LRDFN^HMPXGLAB(DFN)
SET HMPSUB=$GET(FILTER("category"))
+3 SET BEG=HMPSTART
SET END=HMPSTOP
SET LRID=$GET(HMPID)
SET ORPK=""
+4 ;reset for LR7OR1
IF $LENGTH(LRID)
Begin DoDot:1
+5 ;order
IF LRID
SET ORPK=LRID
SET LRID=$PIECE(LRID,";",4,99)
if LRID=""
QUIT
+6 SET HMPSUB=$PIECE(LRID,";")
SET HMPIDT=+$PIECE(LRID,";",2)
+7 if HMPIDT
SET (BEG,END)=9999999-HMPIDT
End DoDot:1
+8 SET SUB=HMPSUB
IF $LENGTH(SUB)
IF "CH^MI"'[SUB
SET SUB="AP"
+9 ; ICR 2503, DE2818
DO RR^LR7OR1(DFN,ORPK,BEG,END,SUB,,,HMPMAX)
+10 SET HMPSUB=""
FOR
SET HMPSUB=$ORDER(^TMP("LRRR",$JOB,DFN,HMPSUB))
if HMPSUB=""
QUIT
Begin DoDot:1
+11 SET HMPIDT=0
FOR
SET HMPIDT=$ORDER(^TMP("LRRR",$JOB,DFN,HMPSUB,HMPIDT))
if HMPIDT<1
QUIT
IF $ORDER(^(HMPIDT,0))
Begin DoDot:2
+12 IF HMPSUB="MI"
SET ID=HMPSUB_";"_HMPIDT
DO MI^HMPDJ06
QUIT
+13 IF HMPSUB'="CH"
SET ID=HMPSUB_";"_HMPIDT
DO AP^HMPDJ06
QUIT
+14 ;get chem accession data
DO ACC^HMPDJ06
+15 SET HMPP=0
FOR
SET HMPP=$ORDER(^TMP("LRRR",$JOB,DFN,HMPSUB,HMPIDT,HMPP))
if HMPP<1
QUIT
SET X=+$GET(^(HMPP))
Begin DoDot:3
+16 SET HMPN=$$LRDN^LRPXAPIU(X)
IF $LENGTH(LRID,";")>2
IF HMPN'=$PIECE(LRID,";",3)
QUIT
+17 SET ID=HMPSUB_";"_HMPIDT_";"_HMPN
DO CH1^HMPDJ06
End DoDot:3
End DoDot:2
if HMPI'<HMPMAX
QUIT
End DoDot:1
+18 KILL ^TMP("LRRR",$JOB),^TMP("LRX",$JOB)
+19 QUIT
+20 ;
PROCEDUR ; -- Clinical Procedures
+1 NEW HMPN,HMPX,BEG,END,ID
+2 SET BEG=HMPSTART
SET END=HMPSTOP
+3 ;reset dates for HMPID only
IF $GET(HMPID)
Begin DoDot:1
+4 NEW HMPMC,IEN,FILE,X
+5 SET IEN=+HMPID
SET FILE=+$PIECE(HMPID,"(",2)
if FILE=702
QUIT
if 'FILE
QUIT
+6 DO MEDLKUP^MCARUTL3(.HMPMC,FILE,IEN)
+7 SET X=$PIECE(HMPMC,U,6)
if X
SET (BEG,END)=X
End DoDot:1
+8 ;gets ^TMP("MDHSP",$J)
DO MDPS1^HMPDJ03(DFN,BEG,END,HMPMAX)
+9 SET HMPN=0
FOR
SET HMPN=$ORDER(^TMP("MDHSP",$JOB,HMPN))
if HMPN<1
QUIT
SET HMPX=$GET(^(HMPN))
Begin DoDot:1
+10 ;update 1 procedure
IF $GET(HMPID)
IF +HMPID'=+$PIECE(HMPX,U,2)
QUIT
+11 ;uses HMPX
DO MC1^HMPDJ03($GET(HMPID))
End DoDot:1
+12 KILL ^TMP("MDHSP",$JOB)
+13 QUIT
+14 ;
OBS ; -- Clinical Observations (CLiO)
+1 NEW HMPCLIO,HMPN,ID,X
+2 IF $LENGTH($GET(HMPID))
DO MDC1^HMPDJ03(HMPID)
QUIT
+3 ;all [verified] observations
DO QRYPT^HMPDMDC("HMPCLIO",DFN,HMPSTART,HMPSTOP)
+4 SET HMPN=0
FOR
SET HMPN=$ORDER(HMPCLIO(HMPN))
if (HMPN<1)!(HMPI'<HMPMAX)
QUIT
Begin DoDot:1
+5 ;GUID
SET ID=$GET(HMPCLIO(HMPN))
+6 DO MDC1^HMPDJ03(ID)
End DoDot:1
+7 QUIT
+8 ;
ORDER ; -- Order Entry
+1 ; DE2818, added HMPORDR, removed X3,X4
NEW DAD,HMPN,HMPORDR,ID,ORLIST,X
+2 IF $GET(HMPID)
SET ORLIST=$HOROLOG
DO OR1^HMPDJ01(HMPID)
GOTO ORQ
+3 ; changed FLG to 1 to get all orders including pending. JD - 1/20/16 - US11951
+4 ; DBIA 3154
DO EN^ORQ1(DFN_";DPT(",,1,,HMPSTART,HMPSTOP,,,,1)
+5 SET HMPN=0
FOR
SET HMPN=$ORDER(^TMP("ORR",$JOB,ORLIST,HMPN))
if HMPN<1
QUIT
SET ID=$GET(^(HMPN))
SET ID=+ID
Begin DoDot:1
+6 ;DE2818, begin logic change
+7 ; kill it for each iteration
KILL HMPORDR
DO ORDINFO(.HMPORDR,ID)
+8 ; (#33) PACKAGE REFERENCE
+9 ; (# 5) STATUS: 13=CANCELLED, 12=DISCONTINUED/EDIT, 1=DISCONTINUED
+10 if $GET(HMPORDR(100,ID,5,"I"))=13
QUIT
IF $GET(HMPORDR(100,ID,33,"I"))["P"
IF ($GET(HMPORDR(100,ID,5,"I"))=12)!($GET(HMPORDR(100,ID,5,"I"))=1)
QUIT
+11 ; Get Parent order if we don't already have it
+12 ; Also, add the child order to the returned list
+13 ;(#36) PARENT
SET DAD=$GET(HMPORDR(100,ID,36,"I"))
+14 IF DAD
if '$DATA(^TMP("ORGOTIT",$JOB,DAD))
DO OR1^HMPDJ01(DAD)
+15 ;DE2818, end logic change
+16 DO OR1^HMPDJ01(ID)
End DoDot:1
if HMPI'<HMPMAX
QUIT
ORQ ; end
+1 KILL ^TMP("ORR",$JOB),^TMP("ORGOTIT",$JOB)
+2 QUIT
+3 ;
TREATMEN ; -- Nursing Treatments (orders)
+1 ;DE2818, added HMPORDR, removed X3,X4
NEW HMPN,HMPORDR,ID,ORDG,ORLIST,X
+2 IF $GET(HMPID)
SET ORLIST=$HOROLOG
DO NTX1^HMPDJ01(HMPID)
GOTO TXQ
+3 ;DE2818, ***replacement for ^ORD reference needed below***
+4 SET ORDG=+$ORDER(^ORD(100.98,"B","NTX",0))
+5 DO EN^ORQ1(DFN_";DPT(",ORDG,6,,HMPSTART,HMPSTOP,,,,1)
+6 SET HMPN=0
FOR
SET HMPN=$ORDER(^TMP("ORR",$JOB,ORLIST,HMPN))
if HMPN<1
QUIT
SET ID=$GET(^(HMPN))
Begin DoDot:1
+7 ;actions
if $DATA(^TMP("ORGOTIT",$JOB,+ID))
QUIT
if $PIECE(ID,";",2)>1
QUIT
SET ID=+ID
+8 ;DE2818, begin logic change
+9 ; kill it for each iteration
KILL HMPORDR
DO ORDINFO(.HMPORDR,ID)
+10 ;(#33) PACKAGE REFERENCE,(#5) STATUS: 13=CANCELLED, 12=DISCONTINUED/EDIT, 1=DISCONTINUED
+11 if $GET(HMPORDR(100,ID,5,"I"))=13
QUIT
IF $GET(HMPORDR(100,ID,33,"I"))["P"
IF ($GET(HMPORDR(100,ID,5,"I"))=12)!($GET(HMPORDR(100,ID,5,"I"))=1)
QUIT
+12 ;DE2818, end logic change
+13 DO NTX1^HMPDJ01(ID)
End DoDot:1
if HMPI'<HMPMAX
QUIT
TXQ ; end
+1 KILL ^TMP("ORR",$JOB),^TMP("ORGOTIT",$JOB)
+2 QUIT
+3 ;
MED ; -- Pharmacy
+1 ;DE2818, removed reference to ^OR(100,HMPID) below
+2 ;get 1 order
NEW ORDIALOG
IF $GET(HMPID)
IF $$GET1^DIQ(100,+HMPID_",",.01)]""
DO PS1^HMPDJ05(HMPID)
QUIT
+3 ;DE2818, added HMPORDR, removed extra ORLIST and X3,X4
NEW DAD,HMPN,HMPORDR,ID,ORDG,ORLIST,ORVP,TYPE
+4 SET TYPE=$GET(FILTER("vaType"))
if $LENGTH(TYPE)
SET TYPE=$SELECT(TYPE="N":"NV",TYPE="V":"IV",1:TYPE)_" "
+5 ;DE2818, ***replacement for ^ORD reference needed below***
+6 ;CPC removed + 10/30/15 DE2434
SET ORDG=$ORDER(^ORD(100.98,"B",TYPE_"RX",0))
SET ORVP=DFN_";DPT("
+7 ;If RX group not found, and not overridden by specific type then try PHARMACY CPC 10/30/15 DE2434
+8 ;CPC 10/30/15 DE2434
IF ORDG=""
SET ORDG=0
IF TYPE=""
SET ORDG=+$ORDER(^ORD(100.98,"B","PHARMACY",0))
+9 DO EN^ORQ1(ORVP,ORDG,6,,HMPSTART,HMPSTOP)
+10 KILL ^TMP("HMPOR",$JOB)
SET HMPN=0
+11 FOR
SET HMPN=$ORDER(^TMP("ORR",$JOB,ORLIST,HMPN))
if HMPN<1
QUIT
SET ID=$GET(^(HMPN))
SET ID=+ID
Begin DoDot:1
+12 ;DE2818, begin logic change
+13 ; kill it for each iteration
KILL HMPORDR
DO ORDINFO(.HMPORDR,ID)
+14 ;(#33) PACKAGE REFERENCE,(#5) STATUS: 13=CANCELLED, 12=DISCONTINUED/EDIT, 1=DISCONTINUED
+15 if $GET(HMPORDR(100,ID,5,"I"))=13
QUIT
IF $GET(HMPORDR(100,ID,33,"I"))["P"
IF ($GET(HMPORDR(100,ID,5,"I"))=12)!($GET(HMPORDR(100,ID,5,"I"))=1)
QUIT
+16 ;(#36) PARENT
SET DAD=$GET(HMPORDR(100,ID,36,"I"))
+17 IF DAD
if '$DATA(^TMP("HMPOR",$JOB,DAD))
DO PS1^HMPDJ05(DAD)
+18 ;DE2818, end logic change
+19 ;DE5156 ensure parent added as well as children
DO PS1^HMPDJ05(ID)
End DoDot:1
if HMPI'<HMPMAX
QUIT
+20 KILL ^TMP("HMPOR",$JOB),^TMP("ORR",$JOB),^TMP("ORGOTIT",$JOB),^TMP($JOB,"PSOI")
+21 QUIT
+22 ;
PTF ; -- Patient Treatment File
+1 ;Purpose - Main Patient Treatment File (PTF) RPC
+2 ;
+3 ;Called by - PTF RPC
+4 ;
+5 ;Assumptions - Expects variables DFN, HMPSTART, HMPSTOP, HMPMAX
+6 ;
+7 ;Modification History -
+8 ;US5630 (TW) - Namespaced variables and enhanced newing
+9 ;
+10 NEW HMPRDT,HMPX,HMPAPI,HMPLID
+11 KILL ^TMP("HMPPX",$JOB)
+12 ;
+13 ; If HMPID and dx type, process and quit
IF $GET(HMPID)
IF HMPID'=+HMPID
DO PTFA^HMPDJ04A(HMPID)
QUIT
+14 ;
+15 ; If HMPID only, set one ^TMP("HMPPX") entry
IF $GET(HMPID)
Begin DoDot:1
+16 SET HMPRDT=9999999
+17 DO RPC^DGPTFAPI(.HMPAPI,HMPID)
+18 SET HMPX=$PIECE($GET(HMPAPI(1)),U,3)
+19 IF $LENGTH(HMPX)
SET ^TMP("HMPPX",$JOB,HMPRDT,HMPID_";70;DXLS")=HMPX_U
+20 FOR HMPAPI=1:1:9
SET HMPX=$PIECE($GET(HMPY(2)),U,HMPAPI)
IF $LENGTH(HMPX)
SET ^TMP("HMPPX",$JOB,HMPRDT,HMPID_";70;D SD"_HMPAPI)=HMPX_U_$GET(DISDAT)
End DoDot:1
if '$DATA(^TMP("HMPPX",$JOB))
QUIT
+21 ;
+22 ; If no HMPID, set up ^TMP("HMPPX") for all dx
IF '$GET(HMPID)
DO PTF^HMPDJ09
+23 ;
+24 ;Loop through ^TMP("HMPPX",$J) and do PTF1^HMPDJ04A to set PTF array, ^TMP
+25 SET HMPRDT=""
FOR
SET HMPRDT=$ORDER(^TMP("HMPPX",$JOB,HMPRDT))
if HMPRDT=""
QUIT
Begin DoDot:1
+26 SET HMPLID=""
FOR
SET HMPLID=$ORDER(^TMP("HMPPX",$JOB,HMPRDT,HMPLID))
if HMPLID=""!(HMPI'<HMPMAX)
QUIT
Begin DoDot:2
+27 DO PTF1^HMPDJ04A
End DoDot:2
End DoDot:1
+28 KILL ^TMP("HMPPX",$JOB)
+29 QUIT
+30 ;
FACTOR ; -- PCE Health Factors
DO PX^HMPDJ09(9000010.23)
QUIT
IMMUNIZA ; -- PCE Immunizations
DO PX^HMPDJ09(9000010.11)
QUIT
EXAM ; -- PCE Exams
DO PX^HMPDJ09(9000010.13)
QUIT
CPT ; -- PCE CPT
DO PX^HMPDJ09(9000010.18)
QUIT
EDUCATIO ; -- PCE Patient Education
DO PX^HMPDJ09(9000010.16)
QUIT
POV ; -- PCE Purpose of Visit (POV)
DO PX^HMPDJ09(9000010.07)
QUIT
SKIN ; -- PCE Skin Tests
DO PX^HMPDJ09(9000010.12)
QUIT
+1 ;
IMAGE ; -- Radiology/Nuclear Medicine
+1 DO EN1^RAO7PC1(DFN,HMPSTART,HMPSTOP,HMPMAX_"P")
+2 IF $GET(HMPID)
DO RA1^HMPDJ07(HMPID)
GOTO IMQ
+3 NEW ID
SET ID=""
+4 FOR
SET ID=$ORDER(^TMP($JOB,"RAE1",DFN,ID))
if ID=""
QUIT
DO RA1^HMPDJ07(ID)
if HMPI'<+HMPMAX
QUIT
IMQ ; end
+1 KILL ^TMP($JOB,"RAE1")
+2 QUIT
+3 ;
APPOINTM ; -- Scheduling/Appointment Mgt
+1 NEW HMPX,HMPNUM,HMPDT,X,HMPA,ID
+2 SET HMPX(1)=HMPSTART_";"_HMPSTOP
SET HMPX(4)=DFN
SET ID=$GET(HMPID)
+3 ;DE4469 - PB - Apr 26, 2016 added field 22 to the list of fields to be pulled.
SET HMPX("FLDS")="1;2;3;6;9;10;11;13;22"
SET HMPX("SORT")="P"
+4 IF $LENGTH(ID)
if $EXTRACT(ID)="H"
GOTO DGS^HMPDJ04
Begin DoDot:1
+5 SET HMPDT=$PIECE(ID,";",2)
SET HMPX(1)=$PIECE(ID,";",2)_";"_$PIECE(ID,";",2)
+6 SET HMPX(2)=$PIECE(ID,";",3)
+7 SET HMPNUM=$$SDAPI^SDAMA301(.HMPX)
+8 if HMPNUM>0
DO SDAM1^HMPDJ04
+9 KILL ^TMP($JOB,"SDAMA301",DFN)
End DoDot:1
QUIT
+10 ; appointments
+11 ;no cancelled appt's
SET HMPX(3)="R;I;NS;NSR;NT"
+12 SET HMPNUM=$$SDAPI^SDAMA301(.HMPX)
SET HMPDT=0
+13 FOR
SET HMPDT=$ORDER(^TMP($JOB,"SDAMA301",DFN,HMPDT))
if HMPDT<1
QUIT
Begin DoDot:1
+14 SET X=$PIECE($GET(^TMP($JOB,"SDAMA301",DFN,HMPDT)),U,3)
+15 ;I HMPDT<DT,$P(X,";")'["NS" Q ;no prior kept appt's
+16 DO SDAM1^HMPDJ04
End DoDot:1
if HMPI'<HMPMAX
QUIT
+17 KILL ^TMP($JOB,"SDAMA301",DFN)
+18 QUIT
+19 ;
SURGERY ; -- Surgery
+1 IF $GET(HMPID)
DO SR1^HMPDJ07(HMPID)
QUIT
+2 if '$LENGTH($TEXT(LIST^SROESTV))
QUIT
+3 ;to omit leading '+' with note titles
NEW SHOWADD
SET SHOWADD=1
+4 NEW HMPN,HMPY,ID
DO LIST^SROESTV(.HMPY,DFN,HMPSTART,HMPSTOP,HMPMAX,1)
+5 SET HMPN=0
FOR
SET HMPN=$ORDER(@HMPY@(HMPN))
if HMPN<1
QUIT
Begin DoDot:1
+6 SET ID=+$GET(@HMPY@(HMPN))
if ID
DO SR1^HMPDJ07(ID)
End DoDot:1
+7 KILL @HMPY
+8 QUIT
+9 ;
DOCUMENT ; -- Text Integration Utilities
+1 NEW HMPC,CLS,HMPS,CTXT,HMPY,HMPN,HMPX,ID
+2 IF $LENGTH($GET(HMPID))
DO TIU1^HMPDJ08(HMPID)
QUIT
+3 NEW CLASS,SUBCLASS,STATUS
+4 ;define search criteria
DO SETUP^HMPDJ08
+5 FOR HMPC=1:1:$LENGTH(CLASS,U)
SET CLS=$PIECE(CLASS,U,HMPC)
Begin DoDot:1
+6 IF CLS="CP"
DO CP^HMPDJ08A(DFN,HMPSTART,HMPSTOP,HMPMAX)
QUIT
+7 IF CLS="RA"
DO RA^HMPDJ08A(DFN,HMPSTART,HMPSTOP,HMPMAX)
QUIT
+8 IF CLS="LR"
DO LR^HMPDJ08A(DFN,HMPSTART,HMPSTOP,HMPMAX)
QUIT
+9 ; TIU document classes, by sig status
+10 FOR HMPS=1:1:$LENGTH(STATUS,U)
SET CTXT=$PIECE(STATUS,U,HMPS)
Begin DoDot:2
+11 ;I $L($G(HMPBATCH)) D GET^TIUHMP(.HMPY,DFN,CLS,HMPSTART,HMPSTOP) I 1 ; <<<< 12.3
+12 ; <<<< 12.3
IF $LENGTH($GET(HMPBATCH))
DO GET^TIUVPR(.HMPY,DFN,CLS,HMPSTART,HMPSTOP)
IF 1
+13 IF '$TEST
DO CONTEXT^TIUSRVLO(.HMPY,CLS,CTXT,DFN,HMPSTART,HMPSTOP,,HMPMAX,,1)
+14 SET HMPN=0
FOR
SET HMPN=$ORDER(@HMPY@(HMPN))
if HMPN<1
QUIT
Begin DoDot:3
+15 ;Q:'$$MATCH^HMPDJ08(HMPX,CTXT)
SET HMPX=$GET(@HMPY@(HMPN))
+16 ;already included
if $DATA(^TMP("HMPD",$JOB,+HMPX))
QUIT
+17 DO EN1^HMPDJ08(HMPX,CLS)
End DoDot:3
if HMPI'<HMPMAX
QUIT
+18 KILL @HMPY
End DoDot:2
if HMPI'<HMPMAX
QUIT
End DoDot:1
if HMPI'<HMPMAX
QUIT
+19 QUIT
+20 ;
VISIT ; -- Visits
+1 IF $LENGTH($GET(HMPID))
DO VSIT1^HMPDJ04(HMPID)
QUIT
+2 ;DE2818, added HMPDEMOG
NEW BEG,END,HMPADMIT,HMPDEMOG,HMPIDT,ID
+3 ;DE2818, (.105) CURRENT ADMISSION
DO TOP^HMPXGDPT("HMPDEMOG",DFN,.105,"I")
+4 ;DE2818
SET HMPADMIT=+$GET(HMPDEMOG(2,DFN,.105,"I"))
+5 ;invert dates
SET BEG=HMPSTART
SET END=HMPSTOP
DO IDT^HMPDVSIT
+6 ;DE2818 ***ICR 2028 needed for ^AUPNVSIT references below***
+7 SET HMPIDT=BEG
FOR
SET HMPIDT=$ORDER(^AUPNVSIT("AA",DFN,HMPIDT))
if HMPIDT<1!(HMPIDT>END)
QUIT
Begin DoDot:1
+8 SET ID=0
FOR
SET ID=$ORDER(^AUPNVSIT("AA",DFN,HMPIDT,ID))
if ID<1
QUIT
DO VSIT1^HMPDJ04(ID)
End DoDot:1
if HMPI'<HMPMAX
QUIT
+9 ; kill HMPADMIT in VSIT1 if adm is included, but add unless filtered
+10 IF $GET(HMPADMIT)
IF HMPMAX'<9999
IF HMPSTART'>1410102
DO VSIT1^HMPDJ04("H"_HMPADMIT)
+11 QUIT
+12 ;I HMPSTOP,HMPSTOP'["." S END=HMPSTOP_".24" ;assume end of day
+13 ;S HMPDT=END F S HMPDT=$O(^AUPNVSIT("AET",DFN,HMPDT),-1) Q:HMPDT<HMPSTART D Q:HMPI'<HMPMAX
+14 ;. S HMPLOC=0 F S HMPLOC=$O(^AUPNVSIT("AET",DFN,HMPDT,HMPLOC)) Q:HMPLOC<1 D
+15 ;.. S ID=0 F S ID=$O(^AUPNVSIT("AET",DFN,HMPDT,HMPLOC,"P",ID)) Q:ID<1 D VSIT1^HMPDJ04(ID)
+16 ;
HMP ; -- HMP Patient Objects
+1 DO HMP^HMPDJ02($GET(TYPE))
+2 QUIT
+3 ;
MH ; -- Mental Health
+1 IF $LENGTH($TEXT(MH^HMPDJ09M))
DO MH^HMPDJ09M
+2 QUIT
+3 ;
ERRQ ; -- Quit for error handling
+1 QUIT
+2 ;
+3 ;new subroutine for DE2818
ORDINFO(ORRSLT,ORIEN) ; ORDER file (#100), ORRSLT passed by reference
+1 ; all data returned in internal format
+2 ;
+3 ; fields on ^OR(100,D0,0)
+4 ;(#.01) ORDER #
+5 ;(#.02) OBJECT OF ORDER
+6 ;
+7 ; fields on ^OR(100,D0,3)
+8 ;(#5) STATUS
+9 ;(#7) ITEM ORDERED
+10 ;(#8) VEILED
+11 ;(#8.1) TYPE
+12 ;(#9) REPLACED ORDER
+13 ;(#9.1) REPLACEMENT ORDER
+14 ;(#30) CURRENT ACTION
+15 ;(#31) DATE OF LAST ACTIVITY
+16 ;(#32) GRACE DAYS BEFORE PURGE
+17 ;(#36) PARENT
+18 ;(#35) ALERT ON RESULTS
+19 ;
+20 ; field on ^OR(100,D0,4)
+21 ;(#33) PACKAGE REFERENCE
+22 ;
+23 ; IEN required
if '($GET(ORIEN)>0)
QUIT
+24 DO TOP^HMPXGORD("ORRSLT",ORIEN,".01;.02;5;7;8;8.1;9;9.1;30;31;32;33;35;36","I")
+25 ;
+26 QUIT
+27 ;end DE2818
+28 ;
