HMPCORD4 ;SLC/AGP,ASMR/RRB,JD -Retrieved Orderable Items;Aug 12, 2016 10:54:47
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ALL^PSS51P2 4548 ;DE6363 - JD - 8/23/16
;
;DE5080 - JD - 7/26/16: Fixed the <UNDEFINED> in VALIDOI section.
;DE4488 - JD - 8/12/16: Replaced direct global read of ^PS(51.2 with ALL^PSS51P2 API in
; ADDROUTE section.
;
Q
;
ADDODG ; called by HMPEF
N CNT,IEN,NUM,NODE,PTR,RESULT,TEMP
N ERRMSG S ERRMSG="A mumps error occurred while extracting display groups"
S IEN=0 F S IEN=$O(^ORD(100.98,IEN)) Q:IEN'>0 D
.N $ES,$ET
.S $ET="D ERRHDLR^HMPDERRH"
.I '$D(^ORD(100.98,IEN,1)) D Q
..S NODE=$G(^ORD(100.98,IEN,0)) D SODGNODE(.RESULT,NODE)
..S RESULT("uid")=$$SETUID^HMPUTILS("displayGroup","",IEN),RESULT("internal")=IEN
..D ADD^HMPEF("RESULT") S HMPCNT=+$G(HMPCNT)+1,HMPLAST=IEN
.D ADDODG1(IEN,.TEMP)
.M RESULT=TEMP
.D ADD^HMPEF("RESULT") S HMPCNT=+$G(HMPCNT)+1,HMPLAST=IEN
I IEN'>0 S HMPFINI=1
Q
;
ADDODG1(IEN,TEMP) ;
N CNT,NODE,NUM,PTR
S NODE=$G(^ORD(100.98,IEN,0)) D SODGNODE(.TEMP,NODE)
S TEMP("uid")=$$SETUID^HMPUTILS("displayGroup","",IEN),TEMP("internal")=IEN
I '$D(^ORD(100.98,IEN,1)) Q
S NUM=0,CNT=0 F S NUM=$O(^ORD(100.98,IEN,1,NUM)) Q:NUM'>0 D
.N ARRAY
.S PTR=$G(^ORD(100.98,IEN,1,NUM,0)) Q:PTR'>0
.D ADDODG1(PTR,.ARRAY) I '$D(ARRAY) Q
.S CNT=CNT+1 M TEMP("children",CNT,"item")=ARRAY
Q
;
SODGNODE(RESULT,NODE) ;
N NAME,TEMP,X
F X=1:1:4 D
.S TEMP=$P(NODE,U,X) I X<4,$L(TEMP)>1 S RESULT($S(X=1:"name",X=2:"displayName",X=3:"abbreviation"))=TEMP
.I X=4,+TEMP>0 S NAME=$P($G(^ORD(101.41,TEMP,0)),U) S RESULT("defaultDialogUid")=$$SETUID^HMPUTILS("orderDialog","",TEMP),RESULT("defaultDialogName")=NAME
Q
;
ADDROUTE ;
;DE4488 - Start
N ERRMSG,IEN
S IEN=0,ERRMSG="A mumps error occurred while extracting routes."
I +$G(HMPLAST)>0 S IEN=HMPLAST
;Replaced direct global [^PS(51.2)] read with ALL^PSS51P2 API - ICR 4548
D ALL^PSS51P2("","??","","","HMPSUB") ;"??" puts ALL med routes into ^TMP($J,"HMPSUB")
F S IEN=$O(^TMP($J,"HMPSUB",IEN)) Q:IEN'>0 D
.N $ES,$ET
.N HMPLCL,RESULT,UID,X ;HMPLCL --> Local array
.S $ET="D ERRHDLR^HMPDERRH"
.K HMPLCL,RESULT
.M HMPLCL=^TMP($J,"HMPSUB",IEN)
.I $G(HMPLCL(5))>0 Q ;Skip over inactive med routes
.S UID=$$SETUID^HMPUTILS("route","",IEN)
.S RESULT("uid")=UID,RESULT("internal")=IEN
.F X=.01,1,4,6 D ;X is the field number from file #51.2 (e.g. .01=NAME)
..N NAME,VALUE
..S VALUE=HMPLCL(X) Q:VALUE=""
..S NAME=$S(X=.01:"name",X=4:"externalName",X=1:"abbreviation",X=6:"useInIV",1:"")
..I NAME="" Q
..I X=6 S VALUE=$S(+VALUE=1:"true",1:"false") ;For X=6,VALUE could either be "" or "1^YES"
..S RESULT(NAME)=VALUE
.D ADD^HMPEF("RESULT") S HMPCNT=+$G(HMPCNT)+1,HMPLAST=IEN
K ^TMP($J,"HMPSUB") ;Cleanup
;DE4488 - End
I IEN'>0 S HMPFINI=1
Q
;
ADDSCH ;
N CNT,IEN,NAME,NODE,NUM,RESULT,UID,HMPSCH
;D SCHALL^ORWDPS1(.HMPSCH,0,0)
D SCHED^PSS51P1(0,.HMPSCH)
N ERRMSG
S ERRMSG="A mumps error occurred while extracting schedules."
S CNT=0 F S CNT=$O(HMPSCH(CNT)) Q:CNT'>0 D
.N $ES,$ET
.S $ET="D ERRHDLR^HMPDERRH"
.S NODE=$G(HMPSCH(CNT))
.S NAME=$P(NODE,U,2)
.S IEN=$P(NODE,U)
.;S IEN=$O(^PS(51.1,"B",NAME,"")) I IEN'>0 Q
.S UID=$$SETUID^HMPUTILS("schedule","",IEN)
.S RESULT("uid")=UID,RESULT("internal")=IEN
.S RESULT("name")=NAME
.I $P(NODE,U,3)'="" S RESULT("externalValue")=$P(NODE,U,3)
.I $P(NODE,U,4)'="" S RESULT("scheduleType")=$P(NODE,U,4)
.D ADD^HMPEF("RESULT") S HMPCNT=+$G(HMPCNT)+1,HMPLAST=IEN
.K RESULT
I CNT'>0 S HMPFINI=1
Q
;
LAB(RESULT,OI) ;
N CNT,I,IEN,NODE,SYN,TEMP,HMPLST
S RESULT("dialogAdditionalInformation","sendPatientTimes",1,"internal")="LT",RESULT("dialogAdditionalInformation","sendPatientTimes",1,"name")="Today"
S RESULT("dialogAdditionalInformation","sendPatientTimes",2,"internal")="LT+1",RESULT("dialogAdditionalInformation","sendPatientTimes",2,"name")="Tomorrow"
;
D GETLST^XPAR(.HMPLST,"ALL","ORWD COMMON LAB INPT") ;DBIA 2263
S I=0 F S I=$O(HMPLST(I)) Q:'I D
. S IEN=$P(HMPLST(I),U,2)
. K P1
. S P1="dialogAdditionalInformation"
. S RESULT("dialogAdditionalInformation","common",I,"uid")=$$SETUID^HMPUTILS("orderable","",IEN)
. S RESULT("dialogAdditionalInformation","common",I,"internal")=IEN
. S RESULT("dialogAdditionalInformation","common",I,"name")=$P(^ORD(101.43,IEN,0),U,1)
;
S NODE=$G(^ORD(101.43,OI,"LR"))
S RESULT("labDetails","speciman")=$P(NODE,U),RESULT("labDetails","labCollect")=$S($P(NODE,U,2)=1:"true",1:"false"),RESULT("labDetails","sequence")=$P(NODE,U,3)
S RESULT("labDetails","maxOrderFrequency")=$P(NODE,U,4),RESULT("labDetails","dailyOrderMax")=$P(NODE,U,5)
;
S TEMP=$P(NODE,U,6)
S RESULT("types",1,"abb")=TEMP,RESULT("types",1,"uid")=$$SETUID^HMPUTILS("labType","",TEMP),RESULT("types",1,"internal")=TEMP,RESULT("types",1,"type")=$$LABTYPE(TEMP)
S TEMP=$P(NODE,U,7)
I TEMP'="" S RESULT("labDetails","labTypeInternal")=TEMP,RESULT("labDetails","labTypeName")=$S(TEMP="I":"Input",TEMP="O":"Output",TEMP="B":"Both",TEMP="N":"Neither")
I '$D(^ORD(101.43,OI,2)) Q
S CNT=0
S I=0 F S I=$O(^ORD(101.43,OI,2,I)) Q:I'>0 D
.S SYN=$G(^ORD(101.43,OI,2,I,0)) Q:SYN=""
.S CNT=CNT+1,RESULT("synonym",CNT,"name")=SYN
Q
;
LABTYPE(L) ;
I L="CH" Q "Chemistry"
I L="MI" Q "MICROBIOLOGY"
I L="BB" Q "Blood Bank"
I L="EM" Q "Electron Microscopy"
I L="SP" Q "Surgical Pathology"
I L="AU" Q "Autopsy"
I L="CY" Q "Cytology"
Q ""
;
OI(OITYPE) ; called by HMPEF
N CNT,ERROR,IEN,NAME,LINK,LINKTYPE,NODE,RADDET,RADTYPE,RESULT,TCNT,TYPE,UID,HMPTEMP
N ERRMSG
S ERRMSG="A mumps error occurred while extracting orderable items."
S CNT=1,IEN=0
;
D RADTYPE(.RADTYPE,.RADDET)
I +$G(HMPLAST)>0 S IEN=HMPLAST
I +$G(HMPID)>0 S IEN=HMPID
F S IEN=$O(^ORD(101.43,IEN)) Q:IEN'>0 D I HMPMAX>0,HMPI'<HMPMAX Q
.N $ES,$ET
.S $ET="D ERRHDLR^HMPDERRH"
.K RESULT
.S TYPE=$$VALIDOI(OITYPE,IEN)
.I TYPE="" Q
.S NAME=$P(^ORD(101.43,IEN,0),U),LINK=$P($P(^ORD(101.43,IEN,0),U,2),";99",1),LINKTYPE=$P($P(^ORD(101.43,IEN,0),U,2),";99",2)
.S UID=$$SETUID^HMPUTILS("orderable","",IEN)
.S RESULT("uid")=UID,RESULT("internal")=IEN
.S RESULT("name")=NAME
.S RESULT("link")=LINK
.S RESULT("linktype")=LINKTYPE
.I TYPE["PS" D PS(.RESULT,IEN,CNT)
.I TYPE["RA" D RA(.RESULT,IEN,CNT,.RADTYPE,.RADDET)
.I TYPE["LR" D LAB(.RESULT,IEN)
.D ADD^HMPEF("RESULT") S HMPCNT=+$G(HMPCNT)+1,HMPLAST=IEN
.S CNT=CNT+1
I IEN'>0 S HMPFINI=1
Q
;
PS(RESULT,IEN,PLACE) ;
N CNT,COST,DOSE,DOSES,DRUG,MEDS,NAME,NODE,NUM,PSOI,SIZE,TYPE,UID,HMPDOSE
S CNT=0
I $D(^ORD(101.43,IEN,9,"B","NV RX")) S CNT=CNT+1 S RESULT("types",CNT,"type")="NON-VA MEDS" S MEDS("NV RX")=""
I $D(^ORD(101.43,IEN,9,"B","O RX")) S CNT=CNT+1 S RESULT("types",CNT,"type")="OUTPATIENT MEDS" S MEDS("O RX")=""
I $D(^ORD(101.43,IEN,9,"B","RX")) S CNT=CNT+1 S RESULT("types",CNT,"type")="MEDS" S MEDS("RX")=""
I $D(^ORD(101.43,IEN,9,"B","UD RX")) S CNT=CNT+1 S RESULT("types",CNT,"type")="INPATIENT MEDS" S MEDS("UD RX")=""
;
K DOSES
S PSOI=+$P(^ORD(101.43,IEN,0),U,2)
S TYPE="" F S TYPE=$O(MEDS(TYPE)) Q:TYPE="" D
.D DOSE^PSSOPKI1(.HMPDOSE,PSOI,TYPE,0)
.S CNT=0 F S CNT=$O(HMPDOSE(CNT)) Q:CNT'>0 D
..S NODE=$G(HMPDOSE(CNT)),SIZE="",UID=0,DRUG="",COST=""
..S DOSE=$P(NODE,U,5)
..I $D(DOSES(DOSE)) Q
..I $P(NODE,U,3)'="",$P(NODE,U,4)'="" S SIZE=$P(NODE,U,3)_" "_$P(NODE,U,4)
..S DRUG=$P(NODE,U,6),COST=$P(NODE,U,7)
..S DOSES(DOSE)=$G(SIZE)_U_DRUG_U_COST
;
S DOSE="",CNT=1 F S DOSE=$O(DOSES(DOSE)) Q:DOSE="" D
.S NODE=DOSES(DOSE)
.S RESULT("possibleDosages",CNT,"dose")=DOSE
.I $P(NODE,U)'="" S RESULT("possibleDosages",CNT,"size")=$P(NODE,U)
.I $P(NODE,U,2)>0 D
..S NAME=$P($G(^PSDRUG($P(NODE,U,2),0)),U)
..S RESULT("possibleDosages",CNT,"drugUid")=$$SETUID^HMPUTILS("drug","",$P(NODE,U,2))
..S RESULT("possibleDosages",CNT,"drugInternal")=$P(NODE,U,2)
..S RESULT("possibleDosages",CNT,"drugName")=NAME
.;I $P(NODE,U,3)'="" S RESULT("possibleDosages",CNT,"cost")=$P(NODE,U,3)
.S CNT=CNT+1
Q
;
RA(RESULT,IEN,PLACE,RADTYPE,RADDET) ;
N CNT,NODE,TEMP
S CNT=0
S NODE=$G(^ORD(101.43,IEN,0))
Q:$P(NODE,U,3)="" ;BL;DE801 NULL SUBSCRIPT FOUND AT TEST SITES
I $P(NODE,U,3)'="",$P(NODE,U,4)'="" S RESULT("code")=$$SETUID^HMPUTILS($$LOW^XLFSTR($P(NODE,U,4)),"",$P(NODE,U,3))
S NODE=$G(^ORD(101.43,IEN,"RA"))
S RESULT("imagingDetails","contractMedia")=$P(NODE,U)
I $P(NODE,U,2)'="" S TEMP=$P(NODE,U,2),RESULT("imagingDetails","procedureType")=$S(TEMP="B":"Board",TEMP="D":"Detailed",TEMP="S":"Series",TEMP="P":"Parent")
I $P(NODE,U,3)'="",$D(RADTYPE($P(NODE,U,3))) D
.S TEMP=$G(RADTYPE($P(NODE,U,3))),RESULT("types",1,"type")=$P(TEMP,U,2),RESULT("types",1,"uid")=$$SETUID^HMPUTILS("radType","",$P(TEMP,U)),RESULT("internal")=$P(TEMP,U),RESULT("types",1,"abb")=$P(NODE,U,3)
.S RESULT("imagingDetails","commonProcedure")=$S($P(NODE,U,4)=1:"true",1:"false")
.I $D(RADTYPE($P(NODE,U,3))) M RESULT("dialogAdditionalInformation")=RADDET($P(NODE,U,3))
Q
;
RADTYPE(RADTYPE,RADDET) ;
;build radiology type array for reused to load imaging types
N ABB,CNT,IMGTYP,SUBMIT,TCNT,URG,VALUES,HMPTEMP,HMPX
D IMTYPSEL^ORWDRA32(.HMPTEMP,"")
D CAT(.VALUES),TRANS(.VALUES),URGENCY(.VALUES)
S TCNT=""
F S TCNT=$O(HMPTEMP(TCNT)) Q:TCNT="" D
.S NODE=HMPTEMP(TCNT)
.S IMGTYP=$P(NODE,U),ABB=$P(NODE,U,3)
.D SUBMIT(.VALUES,ABB)
.S RADTYPE(ABB)=IMGTYP_U_$P(NODE,U,2)_U_$P(NODE,U,4)
.I $D(VALUES) M RADDET(ABB)=VALUES
.;Radiology Modifier
.S I=$O(^RA(79.2,"C",ABB,0)) Q:'I
.S HMPX=0,CNT=0 F S HMPX=$O(^RAMIS(71.2,"AB",I,HMPX)) Q:'HMPX D
..S CNT=CNT+1
..S RADDET(ABB,"modifier",CNT,"uid")=$$SETUID^HMPUTILS("modifier","",HMPX),RADDET(ABB,"modifier",CNT,"internal")=HMPX
..S RADDET(ABB,"modifier",CNT,"name")=$P(^RAMIS(71.2,HMPX,0),U)
Q
;
;Transport values
TRANS(RADDET) ;
N CNT,HMPX
S CNT=0
F HMPX="A^AMBULATORY","P^PORTABLE","S^STRETCHER","W^WHEELCHAIR" D
.S CNT=CNT+1,RADDET("transport",CNT,"uid")=$$SETUID^HMPUTILS("transport","",$P(HMPX,U)),RADDET("transport",CNT,"name")=$P(HMPX,U,2),RADDET("transport",CNT,"internal")=$P(HMPX,U)
Q
;
CAT(RADDET) ;category values
N CNT,HMPX
S CNT=0
F HMPX="I^INPATIENT","O^OUTPATIENT","E^EMPLOYEE","C^CONTRACT","S^SHARING","R^RESEARCH" D
.S CNT=CNT+1,RADDET("category",CNT,"uid")=$$SETUID^HMPUTILS("transport","",$P(HMPX,U)),RADDET("category",CNT,"name")=$P(HMPX,U,2),RADDET("category",CNT,"internal")=$P(HMPX,U)
Q
;
URGENCY(URG) ; Get the allowable urgencies and default
N CNT,I,HMPX
S HMPX="",I=0,CNT=0
F S ORX=$O(^ORD(101.42,"S.RA",HMPX)) Q:HMPX="" D
. S I=$O(^ORD(101.42,"S.RA",HMPX,0))
. S URG("urgency",CNT,"uid")=$$SETUID^HMPUTILS("urgency","",I),URG("urgency",CNT,"internal")=I
. S URG("urgency",CNT,"name")=HMPX
. S URG("urgency",CNT,"default")="false"
. S CNT=CNT+1
S I=$O(^ORD(101.42,"B","ROUTINE",0)) I +I=0 Q
S CNT=CNT+1
S URG("urgency",CNT,"uid")=$$SETUID^HMPUTILS("urgency","",I),URG("urgency",CNT,"internal")=I
S URG("urgency",CNT,"name")="Routine"
S URG("urgency",CNT,"default")="true"
Q
;
SUBMIT(SUBMIT,IMGTYP) ; Get the locations to which the request may be submitted
N CNT,FIRST,TMPLST,ASK,HMPX
S CNT=0
D EN4^RAO7PC1(IMGTYP,"TMPLST")
S FIRST=1
S I=0 F S I=$O(TMPLST(I)) Q:'I D
. S CNT=CNT+1,HMPX=$P(TMPLST(I),U,1,2),SUBMIT("submit",CNT,"name")=$P(HMPX,U,2)
. S SUBMIT("submit",CNT,"default")=$S(FIRST=1:"true",1:"false")
. S SUBMIT("submit",CNT,"uid")=$$SETUID^HMPUTILS("imagingLocation","",$P(HMPX,U)),SUBMIT("submit",CNT,"internal")=$P(HMPX,U),FIRST=0
S HMPX=$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q")
S ASK=$S($L(HMPX):HMPX,1:1)
S SUBMIT("askSubmit")=$S(ASK=1:"true",ASK=0:"false",1:"true")
Q
;
QO ;
N IEN,NAME,NODE,RESULT
N ERRMSG S ERRMSG="A mumps error occurred while extracting orderable items."
S IEN=0 F S IEN=$O(^ORD(101.41,IEN)) Q:IEN'>0 D
.N $ES,$ET
.S $ET="D ERRHDLR^HMPDERRH"
.S NODE=$G(^ORD(101.41,IEN,0)) I $P(NODE,U,4)'="Q" Q
.S NAME=$S($P(NODE,U,2)'="":$P(NODE,U,2),1:$P(NODE,U))
.S RESULT("name")=NAME
.S RESULT("uid")=$$SETUID^HMPUTILS("qo","",IEN),RESULT("internal")=IEN
.S HMPCNT=HMPCNT+1 D ADD^HMPEF("RESULT")
I IEN'>0 S HMPFINI=1
Q
;
VALIDOI(OITYPE,IEN) ;
N TEMP,TYPE
I $G(^ORD(101.43,IEN,0))'=""
S TEMP=$P($G(^ORD(101.43,IEN,0)),U,2) ;Added $G for DE5080
S TYPE=$P(TEMP,";",2)
S TYPE=$E(TYPE,3,$L(TYPE))
I OITYPE="" Q TYPE
I TYPE["PS" Q TYPE
I OITYPE[TYPE Q TYPE
Q ""
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPCORD4 12741 printed Sep 23, 2025@19:29:03 Page 2
HMPCORD4 ;SLC/AGP,ASMR/RRB,JD -Retrieved Orderable Items;Aug 12, 2016 10:54:47
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ALL^PSS51P2 4548 ;DE6363 - JD - 8/23/16
+7 ;
+8 ;DE5080 - JD - 7/26/16: Fixed the <UNDEFINED> in VALIDOI section.
+9 ;DE4488 - JD - 8/12/16: Replaced direct global read of ^PS(51.2 with ALL^PSS51P2 API in
+10 ; ADDROUTE section.
+11 ;
+12 QUIT
+13 ;
ADDODG ; called by HMPEF
+1 NEW CNT,IEN,NUM,NODE,PTR,RESULT,TEMP
+2 NEW ERRMSG
SET ERRMSG="A mumps error occurred while extracting display groups"
+3 SET IEN=0
FOR
SET IEN=$ORDER(^ORD(100.98,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+4 NEW $ESTACK,$ETRAP
+5 SET $ETRAP="D ERRHDLR^HMPDERRH"
+6 IF '$DATA(^ORD(100.98,IEN,1))
Begin DoDot:2
+7 SET NODE=$GET(^ORD(100.98,IEN,0))
DO SODGNODE(.RESULT,NODE)
+8 SET RESULT("uid")=$$SETUID^HMPUTILS("displayGroup","",IEN)
SET RESULT("internal")=IEN
+9 DO ADD^HMPEF("RESULT")
SET HMPCNT=+$GET(HMPCNT)+1
SET HMPLAST=IEN
End DoDot:2
QUIT
+10 DO ADDODG1(IEN,.TEMP)
+11 MERGE RESULT=TEMP
+12 DO ADD^HMPEF("RESULT")
SET HMPCNT=+$GET(HMPCNT)+1
SET HMPLAST=IEN
End DoDot:1
+13 IF IEN'>0
SET HMPFINI=1
+14 QUIT
+15 ;
ADDODG1(IEN,TEMP) ;
+1 NEW CNT,NODE,NUM,PTR
+2 SET NODE=$GET(^ORD(100.98,IEN,0))
DO SODGNODE(.TEMP,NODE)
+3 SET TEMP("uid")=$$SETUID^HMPUTILS("displayGroup","",IEN)
SET TEMP("internal")=IEN
+4 IF '$DATA(^ORD(100.98,IEN,1))
QUIT
+5 SET NUM=0
SET CNT=0
FOR
SET NUM=$ORDER(^ORD(100.98,IEN,1,NUM))
if NUM'>0
QUIT
Begin DoDot:1
+6 NEW ARRAY
+7 SET PTR=$GET(^ORD(100.98,IEN,1,NUM,0))
if PTR'>0
QUIT
+8 DO ADDODG1(PTR,.ARRAY)
IF '$DATA(ARRAY)
QUIT
+9 SET CNT=CNT+1
MERGE TEMP("children",CNT,"item")=ARRAY
End DoDot:1
+10 QUIT
+11 ;
SODGNODE(RESULT,NODE) ;
+1 NEW NAME,TEMP,X
+2 FOR X=1:1:4
Begin DoDot:1
+3 SET TEMP=$PIECE(NODE,U,X)
IF X<4
IF $LENGTH(TEMP)>1
SET RESULT($SELECT(X=1:"name",X=2:"displayName",X=3:"abbreviation"))=TEMP
+4 IF X=4
IF +TEMP>0
SET NAME=$PIECE($GET(^ORD(101.41,TEMP,0)),U)
SET RESULT("defaultDialogUid")=$$SETUID^HMPUTILS("orderDialog","",TEMP)
SET RESULT("defaultDialogName")=NAME
End DoDot:1
+5 QUIT
+6 ;
ADDROUTE ;
+1 ;DE4488 - Start
+2 NEW ERRMSG,IEN
+3 SET IEN=0
SET ERRMSG="A mumps error occurred while extracting routes."
+4 IF +$GET(HMPLAST)>0
SET IEN=HMPLAST
+5 ;Replaced direct global [^PS(51.2)] read with ALL^PSS51P2 API - ICR 4548
+6 ;"??" puts ALL med routes into ^TMP($J,"HMPSUB")
DO ALL^PSS51P2("","??","","","HMPSUB")
+7 FOR
SET IEN=$ORDER(^TMP($JOB,"HMPSUB",IEN))
if IEN'>0
QUIT
Begin DoDot:1
+8 NEW $ESTACK,$ETRAP
+9 ;HMPLCL --> Local array
NEW HMPLCL,RESULT,UID,X
+10 SET $ETRAP="D ERRHDLR^HMPDERRH"
+11 KILL HMPLCL,RESULT
+12 MERGE HMPLCL=^TMP($JOB,"HMPSUB",IEN)
+13 ;Skip over inactive med routes
IF $GET(HMPLCL(5))>0
QUIT
+14 SET UID=$$SETUID^HMPUTILS("route","",IEN)
+15 SET RESULT("uid")=UID
SET RESULT("internal")=IEN
+16 ;X is the field number from file #51.2 (e.g. .01=NAME)
FOR X=.01,1,4,6
Begin DoDot:2
+17 NEW NAME,VALUE
+18 SET VALUE=HMPLCL(X)
if VALUE=""
QUIT
+19 SET NAME=$SELECT(X=.01:"name",X=4:"externalName",X=1:"abbreviation",X=6:"useInIV",1:"")
+20 IF NAME=""
QUIT
+21 ;For X=6,VALUE could either be "" or "1^YES"
IF X=6
SET VALUE=$SELECT(+VALUE=1:"true",1:"false")
+22 SET RESULT(NAME)=VALUE
End DoDot:2
+23 DO ADD^HMPEF("RESULT")
SET HMPCNT=+$GET(HMPCNT)+1
SET HMPLAST=IEN
End DoDot:1
+24 ;Cleanup
KILL ^TMP($JOB,"HMPSUB")
+25 ;DE4488 - End
+26 IF IEN'>0
SET HMPFINI=1
+27 QUIT
+28 ;
ADDSCH ;
+1 NEW CNT,IEN,NAME,NODE,NUM,RESULT,UID,HMPSCH
+2 ;D SCHALL^ORWDPS1(.HMPSCH,0,0)
+3 DO SCHED^PSS51P1(0,.HMPSCH)
+4 NEW ERRMSG
+5 SET ERRMSG="A mumps error occurred while extracting schedules."
+6 SET CNT=0
FOR
SET CNT=$ORDER(HMPSCH(CNT))
if CNT'>0
QUIT
Begin DoDot:1
+7 NEW $ESTACK,$ETRAP
+8 SET $ETRAP="D ERRHDLR^HMPDERRH"
+9 SET NODE=$GET(HMPSCH(CNT))
+10 SET NAME=$PIECE(NODE,U,2)
+11 SET IEN=$PIECE(NODE,U)
+12 ;S IEN=$O(^PS(51.1,"B",NAME,"")) I IEN'>0 Q
+13 SET UID=$$SETUID^HMPUTILS("schedule","",IEN)
+14 SET RESULT("uid")=UID
SET RESULT("internal")=IEN
+15 SET RESULT("name")=NAME
+16 IF $PIECE(NODE,U,3)'=""
SET RESULT("externalValue")=$PIECE(NODE,U,3)
+17 IF $PIECE(NODE,U,4)'=""
SET RESULT("scheduleType")=$PIECE(NODE,U,4)
+18 DO ADD^HMPEF("RESULT")
SET HMPCNT=+$GET(HMPCNT)+1
SET HMPLAST=IEN
+19 KILL RESULT
End DoDot:1
+20 IF CNT'>0
SET HMPFINI=1
+21 QUIT
+22 ;
LAB(RESULT,OI) ;
+1 NEW CNT,I,IEN,NODE,SYN,TEMP,HMPLST
+2 SET RESULT("dialogAdditionalInformation","sendPatientTimes",1,"internal")="LT"
SET RESULT("dialogAdditionalInformation","sendPatientTimes",1,"name")="Today"
+3 SET RESULT("dialogAdditionalInformation","sendPatientTimes",2,"internal")="LT+1"
SET RESULT("dialogAdditionalInformation","sendPatientTimes",2,"name")="Tomorrow"
+4 ;
+5 ;DBIA 2263
DO GETLST^XPAR(.HMPLST,"ALL","ORWD COMMON LAB INPT")
+6 SET I=0
FOR
SET I=$ORDER(HMPLST(I))
if 'I
QUIT
Begin DoDot:1
+7 SET IEN=$PIECE(HMPLST(I),U,2)
+8 KILL P1
+9 SET P1="dialogAdditionalInformation"
+10 SET RESULT("dialogAdditionalInformation","common",I,"uid")=$$SETUID^HMPUTILS("orderable","",IEN)
+11 SET RESULT("dialogAdditionalInformation","common",I,"internal")=IEN
+12 SET RESULT("dialogAdditionalInformation","common",I,"name")=$PIECE(^ORD(101.43,IEN,0),U,1)
End DoDot:1
+13 ;
+14 SET NODE=$GET(^ORD(101.43,OI,"LR"))
+15 SET RESULT("labDetails","speciman")=$PIECE(NODE,U)
SET RESULT("labDetails","labCollect")=$SELECT($PIECE(NODE,U,2)=1:"true",1:"false")
SET RESULT("labDetails","sequence")=$PIECE(NODE,U,3)
+16 SET RESULT("labDetails","maxOrderFrequency")=$PIECE(NODE,U,4)
SET RESULT("labDetails","dailyOrderMax")=$PIECE(NODE,U,5)
+17 ;
+18 SET TEMP=$PIECE(NODE,U,6)
+19 SET RESULT("types",1,"abb")=TEMP
SET RESULT("types",1,"uid")=$$SETUID^HMPUTILS("labType","",TEMP)
SET RESULT("types",1,"internal")=TEMP
SET RESULT("types",1,"type")=$$LABTYPE(TEMP)
+20 SET TEMP=$PIECE(NODE,U,7)
+21 IF TEMP'=""
SET RESULT("labDetails","labTypeInternal")=TEMP
SET RESULT("labDetails","labTypeName")=$SELECT(TEMP="I":"Input",TEMP="O":"Output",TEMP="B":"Both",TEMP="N":"Neither")
+22 IF '$DATA(^ORD(101.43,OI,2))
QUIT
+23 SET CNT=0
+24 SET I=0
FOR
SET I=$ORDER(^ORD(101.43,OI,2,I))
if I'>0
QUIT
Begin DoDot:1
+25 SET SYN=$GET(^ORD(101.43,OI,2,I,0))
if SYN=""
QUIT
+26 SET CNT=CNT+1
SET RESULT("synonym",CNT,"name")=SYN
End DoDot:1
+27 QUIT
+28 ;
LABTYPE(L) ;
+1 IF L="CH"
QUIT "Chemistry"
+2 IF L="MI"
QUIT "MICROBIOLOGY"
+3 IF L="BB"
QUIT "Blood Bank"
+4 IF L="EM"
QUIT "Electron Microscopy"
+5 IF L="SP"
QUIT "Surgical Pathology"
+6 IF L="AU"
QUIT "Autopsy"
+7 IF L="CY"
QUIT "Cytology"
+8 QUIT ""
+9 ;
OI(OITYPE) ; called by HMPEF
+1 NEW CNT,ERROR,IEN,NAME,LINK,LINKTYPE,NODE,RADDET,RADTYPE,RESULT,TCNT,TYPE,UID,HMPTEMP
+2 NEW ERRMSG
+3 SET ERRMSG="A mumps error occurred while extracting orderable items."
+4 SET CNT=1
SET IEN=0
+5 ;
+6 DO RADTYPE(.RADTYPE,.RADDET)
+7 IF +$GET(HMPLAST)>0
SET IEN=HMPLAST
+8 IF +$GET(HMPID)>0
SET IEN=HMPID
+9 FOR
SET IEN=$ORDER(^ORD(101.43,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+10 NEW $ESTACK,$ETRAP
+11 SET $ETRAP="D ERRHDLR^HMPDERRH"
+12 KILL RESULT
+13 SET TYPE=$$VALIDOI(OITYPE,IEN)
+14 IF TYPE=""
QUIT
+15 SET NAME=$PIECE(^ORD(101.43,IEN,0),U)
SET LINK=$PIECE($PIECE(^ORD(101.43,IEN,0),U,2),";99",1)
SET LINKTYPE=$PIECE($PIECE(^ORD(101.43,IEN,0),U,2),";99",2)
+16 SET UID=$$SETUID^HMPUTILS("orderable","",IEN)
+17 SET RESULT("uid")=UID
SET RESULT("internal")=IEN
+18 SET RESULT("name")=NAME
+19 SET RESULT("link")=LINK
+20 SET RESULT("linktype")=LINKTYPE
+21 IF TYPE["PS"
DO PS(.RESULT,IEN,CNT)
+22 IF TYPE["RA"
DO RA(.RESULT,IEN,CNT,.RADTYPE,.RADDET)
+23 IF TYPE["LR"
DO LAB(.RESULT,IEN)
+24 DO ADD^HMPEF("RESULT")
SET HMPCNT=+$GET(HMPCNT)+1
SET HMPLAST=IEN
+25 SET CNT=CNT+1
End DoDot:1
IF HMPMAX>0
IF HMPI'<HMPMAX
QUIT
+26 IF IEN'>0
SET HMPFINI=1
+27 QUIT
+28 ;
PS(RESULT,IEN,PLACE) ;
+1 NEW CNT,COST,DOSE,DOSES,DRUG,MEDS,NAME,NODE,NUM,PSOI,SIZE,TYPE,UID,HMPDOSE
+2 SET CNT=0
+3 IF $DATA(^ORD(101.43,IEN,9,"B","NV RX"))
SET CNT=CNT+1
SET RESULT("types",CNT,"type")="NON-VA MEDS"
SET MEDS("NV RX")=""
+4 IF $DATA(^ORD(101.43,IEN,9,"B","O RX"))
SET CNT=CNT+1
SET RESULT("types",CNT,"type")="OUTPATIENT MEDS"
SET MEDS("O RX")=""
+5 IF $DATA(^ORD(101.43,IEN,9,"B","RX"))
SET CNT=CNT+1
SET RESULT("types",CNT,"type")="MEDS"
SET MEDS("RX")=""
+6 IF $DATA(^ORD(101.43,IEN,9,"B","UD RX"))
SET CNT=CNT+1
SET RESULT("types",CNT,"type")="INPATIENT MEDS"
SET MEDS("UD RX")=""
+7 ;
+8 KILL DOSES
+9 SET PSOI=+$PIECE(^ORD(101.43,IEN,0),U,2)
+10 SET TYPE=""
FOR
SET TYPE=$ORDER(MEDS(TYPE))
if TYPE=""
QUIT
Begin DoDot:1
+11 DO DOSE^PSSOPKI1(.HMPDOSE,PSOI,TYPE,0)
+12 SET CNT=0
FOR
SET CNT=$ORDER(HMPDOSE(CNT))
if CNT'>0
QUIT
Begin DoDot:2
+13 SET NODE=$GET(HMPDOSE(CNT))
SET SIZE=""
SET UID=0
SET DRUG=""
SET COST=""
+14 SET DOSE=$PIECE(NODE,U,5)
+15 IF $DATA(DOSES(DOSE))
QUIT
+16 IF $PIECE(NODE,U,3)'=""
IF $PIECE(NODE,U,4)'=""
SET SIZE=$PIECE(NODE,U,3)_" "_$PIECE(NODE,U,4)
+17 SET DRUG=$PIECE(NODE,U,6)
SET COST=$PIECE(NODE,U,7)
+18 SET DOSES(DOSE)=$GET(SIZE)_U_DRUG_U_COST
End DoDot:2
End DoDot:1
+19 ;
+20 SET DOSE=""
SET CNT=1
FOR
SET DOSE=$ORDER(DOSES(DOSE))
if DOSE=""
QUIT
Begin DoDot:1
+21 SET NODE=DOSES(DOSE)
+22 SET RESULT("possibleDosages",CNT,"dose")=DOSE
+23 IF $PIECE(NODE,U)'=""
SET RESULT("possibleDosages",CNT,"size")=$PIECE(NODE,U)
+24 IF $PIECE(NODE,U,2)>0
Begin DoDot:2
+25 SET NAME=$PIECE($GET(^PSDRUG($PIECE(NODE,U,2),0)),U)
+26 SET RESULT("possibleDosages",CNT,"drugUid")=$$SETUID^HMPUTILS("drug","",$PIECE(NODE,U,2))
+27 SET RESULT("possibleDosages",CNT,"drugInternal")=$PIECE(NODE,U,2)
+28 SET RESULT("possibleDosages",CNT,"drugName")=NAME
End DoDot:2
+29 ;I $P(NODE,U,3)'="" S RESULT("possibleDosages",CNT,"cost")=$P(NODE,U,3)
+30 SET CNT=CNT+1
End DoDot:1
+31 QUIT
+32 ;
RA(RESULT,IEN,PLACE,RADTYPE,RADDET) ;
+1 NEW CNT,NODE,TEMP
+2 SET CNT=0
+3 SET NODE=$GET(^ORD(101.43,IEN,0))
+4 ;BL;DE801 NULL SUBSCRIPT FOUND AT TEST SITES
if $PIECE(NODE,U,3)=""
QUIT
+5 IF $PIECE(NODE,U,3)'=""
IF $PIECE(NODE,U,4)'=""
SET RESULT("code")=$$SETUID^HMPUTILS($$LOW^XLFSTR($PIECE(NODE,U,4)),"",$PIECE(NODE,U,3))
+6 SET NODE=$GET(^ORD(101.43,IEN,"RA"))
+7 SET RESULT("imagingDetails","contractMedia")=$PIECE(NODE,U)
+8 IF $PIECE(NODE,U,2)'=""
SET TEMP=$PIECE(NODE,U,2)
SET RESULT("imagingDetails","procedureType")=$SELECT(TEMP="B":"Board",TEMP="D":"Detailed",TEMP="S":"Series",TEMP="P":"Parent")
+9 IF $PIECE(NODE,U,3)'=""
IF $DATA(RADTYPE($PIECE(NODE,U,3)))
Begin DoDot:1
+10 SET TEMP=$GET(RADTYPE($PIECE(NODE,U,3)))
SET RESULT("types",1,"type")=$PIECE(TEMP,U,2)
SET RESULT("types",1,"uid")=$$SETUID^HMPUTILS("radType","",$PIECE(TEMP,U))
SET RESULT("internal")=$PIECE(TEMP,U)
SET RESULT("types",1,"abb")=$PIECE(NODE,U,3)
+11 SET RESULT("imagingDetails","commonProcedure")=$SELECT($PIECE(NODE,U,4)=1:"true",1:"false")
+12 IF $DATA(RADTYPE($PIECE(NODE,U,3)))
MERGE RESULT("dialogAdditionalInformation")=RADDET($PIECE(NODE,U,3))
End DoDot:1
+13 QUIT
+14 ;
RADTYPE(RADTYPE,RADDET) ;
+1 ;build radiology type array for reused to load imaging types
+2 NEW ABB,CNT,IMGTYP,SUBMIT,TCNT,URG,VALUES,HMPTEMP,HMPX
+3 DO IMTYPSEL^ORWDRA32(.HMPTEMP,"")
+4 DO CAT(.VALUES)
DO TRANS(.VALUES)
DO URGENCY(.VALUES)
+5 SET TCNT=""
+6 FOR
SET TCNT=$ORDER(HMPTEMP(TCNT))
if TCNT=""
QUIT
Begin DoDot:1
+7 SET NODE=HMPTEMP(TCNT)
+8 SET IMGTYP=$PIECE(NODE,U)
SET ABB=$PIECE(NODE,U,3)
+9 DO SUBMIT(.VALUES,ABB)
+10 SET RADTYPE(ABB)=IMGTYP_U_$PIECE(NODE,U,2)_U_$PIECE(NODE,U,4)
+11 IF $DATA(VALUES)
MERGE RADDET(ABB)=VALUES
+12 ;Radiology Modifier
+13 SET I=$ORDER(^RA(79.2,"C",ABB,0))
if 'I
QUIT
+14 SET HMPX=0
SET CNT=0
FOR
SET HMPX=$ORDER(^RAMIS(71.2,"AB",I,HMPX))
if 'HMPX
QUIT
Begin DoDot:2
+15 SET CNT=CNT+1
+16 SET RADDET(ABB,"modifier",CNT,"uid")=$$SETUID^HMPUTILS("modifier","",HMPX)
SET RADDET(ABB,"modifier",CNT,"internal")=HMPX
+17 SET RADDET(ABB,"modifier",CNT,"name")=$PIECE(^RAMIS(71.2,HMPX,0),U)
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
+20 ;Transport values
TRANS(RADDET) ;
+1 NEW CNT,HMPX
+2 SET CNT=0
+3 FOR HMPX="A^AMBULATORY","P^PORTABLE","S^STRETCHER","W^WHEELCHAIR"
Begin DoDot:1
+4 SET CNT=CNT+1
SET RADDET("transport",CNT,"uid")=$$SETUID^HMPUTILS("transport","",$PIECE(HMPX,U))
SET RADDET("transport",CNT,"name")=$PIECE(HMPX,U,2)
SET RADDET("transport",CNT,"internal")=$PIECE(HMPX,U)
End DoDot:1
+5 QUIT
+6 ;
CAT(RADDET) ;category values
+1 NEW CNT,HMPX
+2 SET CNT=0
+3 FOR HMPX="I^INPATIENT","O^OUTPATIENT","E^EMPLOYEE","C^CONTRACT","S^SHARING","R^RESEARCH"
Begin DoDot:1
+4 SET CNT=CNT+1
SET RADDET("category",CNT,"uid")=$$SETUID^HMPUTILS("transport","",$PIECE(HMPX,U))
SET RADDET("category",CNT,"name")=$PIECE(HMPX,U,2)
SET RADDET("category",CNT,"internal")=$PIECE(HMPX,U)
End DoDot:1
+5 QUIT
+6 ;
URGENCY(URG) ; Get the allowable urgencies and default
+1 NEW CNT,I,HMPX
+2 SET HMPX=""
SET I=0
SET CNT=0
+3 FOR
SET ORX=$ORDER(^ORD(101.42,"S.RA",HMPX))
if HMPX=""
QUIT
Begin DoDot:1
+4 SET I=$ORDER(^ORD(101.42,"S.RA",HMPX,0))
+5 SET URG("urgency",CNT,"uid")=$$SETUID^HMPUTILS("urgency","",I)
SET URG("urgency",CNT,"internal")=I
+6 SET URG("urgency",CNT,"name")=HMPX
+7 SET URG("urgency",CNT,"default")="false"
+8 SET CNT=CNT+1
End DoDot:1
+9 SET I=$ORDER(^ORD(101.42,"B","ROUTINE",0))
IF +I=0
QUIT
+10 SET CNT=CNT+1
+11 SET URG("urgency",CNT,"uid")=$$SETUID^HMPUTILS("urgency","",I)
SET URG("urgency",CNT,"internal")=I
+12 SET URG("urgency",CNT,"name")="Routine"
+13 SET URG("urgency",CNT,"default")="true"
+14 QUIT
+15 ;
SUBMIT(SUBMIT,IMGTYP) ; Get the locations to which the request may be submitted
+1 NEW CNT,FIRST,TMPLST,ASK,HMPX
+2 SET CNT=0
+3 DO EN4^RAO7PC1(IMGTYP,"TMPLST")
+4 SET FIRST=1
+5 SET I=0
FOR
SET I=$ORDER(TMPLST(I))
if 'I
QUIT
Begin DoDot:1
+6 SET CNT=CNT+1
SET HMPX=$PIECE(TMPLST(I),U,1,2)
SET SUBMIT("submit",CNT,"name")=$PIECE(HMPX,U,2)
+7 SET SUBMIT("submit",CNT,"default")=$SELECT(FIRST=1:"true",1:"false")
+8 SET SUBMIT("submit",CNT,"uid")=$$SETUID^HMPUTILS("imagingLocation","",$PIECE(HMPX,U))
SET SUBMIT("submit",CNT,"internal")=$PIECE(HMPX,U)
SET FIRST=0
End DoDot:1
+9 SET HMPX=$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q")
+10 SET ASK=$SELECT($LENGTH(HMPX):HMPX,1:1)
+11 SET SUBMIT("askSubmit")=$SELECT(ASK=1:"true",ASK=0:"false",1:"true")
+12 QUIT
+13 ;
QO ;
+1 NEW IEN,NAME,NODE,RESULT
+2 NEW ERRMSG
SET ERRMSG="A mumps error occurred while extracting orderable items."
+3 SET IEN=0
FOR
SET IEN=$ORDER(^ORD(101.41,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+4 NEW $ESTACK,$ETRAP
+5 SET $ETRAP="D ERRHDLR^HMPDERRH"
+6 SET NODE=$GET(^ORD(101.41,IEN,0))
IF $PIECE(NODE,U,4)'="Q"
QUIT
+7 SET NAME=$SELECT($PIECE(NODE,U,2)'="":$PIECE(NODE,U,2),1:$PIECE(NODE,U))
+8 SET RESULT("name")=NAME
+9 SET RESULT("uid")=$$SETUID^HMPUTILS("qo","",IEN)
SET RESULT("internal")=IEN
+10 SET HMPCNT=HMPCNT+1
DO ADD^HMPEF("RESULT")
End DoDot:1
+11 IF IEN'>0
SET HMPFINI=1
+12 QUIT
+13 ;
VALIDOI(OITYPE,IEN) ;
+1 NEW TEMP,TYPE
+2 IF $GET(^ORD(101.43,IEN,0))'=""
+3 ;Added $G for DE5080
SET TEMP=$PIECE($GET(^ORD(101.43,IEN,0)),U,2)
+4 SET TYPE=$PIECE(TEMP,";",2)
+5 SET TYPE=$EXTRACT(TYPE,3,$LENGTH(TYPE))
+6 IF OITYPE=""
QUIT TYPE
+7 IF TYPE["PS"
QUIT TYPE
+8 IF OITYPE[TYPE
QUIT TYPE
+9 QUIT ""
+10 ;
