HMPCORD5 ;SLC/AGP,ASMR/EJK,RRB - Retrieved Orderable Items;Sep 1, 2016 17:27:27
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; DE2497/RRB - Removed unused variable, HMP777
;
; DE6652 - JD - 9/1/16: Removed code behind synching sign-symptom domain for operational data.
; SIGNS tag.
;
Q
;
IMMTYPE ;
N ORWLST,ORDT,HMPIMM
S (ORWLST,ORDT)=""
S (HMPCNT,HMPLAST,HMPI)=0
N IMM
;D IMMTYPE^ORWPCE2(.ORWLST,ORDT) ;use existing broker call ORWPCE GET IMMUNIZATION TYPE
N IEN,CNT,BINDEX S (IEN,CNT)=0
S:'$G(ORDT) ORDT=DT
; ^AUTTIMM - IMMUNIZATION file #9999999.14, ***DBIA2454 subscription needed***
F S IEN=$O(^AUTTIMM(IEN)) Q:IEN=""!(IEN'?1N.N) D
. I $D(^AUTTIMM(IEN,0))#2,+$P(^(0),"^",7)=0 S CNT=CNT+1,ORWLST(CNT)=IEN_"^"_$G(^(0))
. Q
S IMM="",HMPIMM=""
F S IMM=$O(ORWLST(IMM)) Q:IMM="" D
. S HMPIMM("localId")=$P(ORWLST(IMM),"^",1) ;get the ien for each item found
. S HMPIMM("name")=$P(ORWLST(IMM),"^",2) ;get the name for each item found
. S HMPIMM("mnemonic")=$P(ORWLST(IMM),"^",3) ;get the mnemonic for each entry
. S HMPIMM("uid")=$$SETUID^HMPUTILS("immunization",,HMPIMM("localId")) ;set the uid string
. S HMPCNT=HMPCNT+1
. D ADD^HMPEF("HMPIMM") S HMPLAST=HMPCNT ;add it to the JSON results array
. Q
S HMPFINI=1
Q
;
ALLTYPE ; deprecated
;N ORX,ROOT,XP,CNT,ORFILE,ORSRC,ORIEN,ORREAX,ALLCNT,ALLLAST,ALLITEM
;S ORIEN=0,CNT=0,ORSRC=0,ORFILE="",ALLCNT=0,ALLLAST=0
;S X=""
;F ROOT="^GMRD(120.82)","^PSNDF(50.6)","^PSNDF(50.67)","^PSDRUG(""B"")","^PS(50.416)","^PS(50.605)" D
;F ROOT="^GMRD(120.82,""B"")","^GMRD(120.82,""D"")","^PSDRUG(""C"")","^PS(50.416,""P"")","^PS(50.605,""C"")",$$B^PSNAPIS,$$T^PSNAPIS,"^PSDRUG(""B"")" D
;F ROOT="^GMRD(120.82,""B"")","^PSDRUG(""C"")","^PS(50.416,""P"")","^PS(50.605,""C"")",$$B^PSNAPIS,$$T^PSNAPIS,"^PSDRUG(""B"")" D
;. S ORSRC=$G(ORSRC)+1,ORFILE=$P(ROOT,",",1)_")",ORSRC(ORSRC)=$P($T(FILENAME+ORSRC),";;",2)
;. I (ORSRC'=2),(ORSRC'=6) S:'$D(Y(ORIEN_";"_ROOT)) CNT=CNT+1,Y(ORIEN_";"_ROOT)=ORSRC_U_ORSRC(ORSRC)_U_U_U_"TOP"_U_"+"
;. I ORSRC=1!(ORSRC=2) D
;.. F S X=$O(@ROOT@(X)) Q:X="" D
;... I ORSRC=1,X="OTHER ALLERGY/ADVERSE REACTION" Q ;don't send this entry
;... S ORIEN=$O(@ROOT@(X,0))
;... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.82,.01,ORIEN_",") Q ;233 Is term active?
;... I ORSRC=2 S:'$D(Y(ORIEN_";"_ROOT)) CNT=CNT+1,Y(ORIEN_";"_ROOT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_X_">"_ROOT
;... I ORSRC'=2 S:'$D(Y(ORIEN_";"_ROOT)) CNT=CNT+1,Y(ORIEN_";"_ROOT)=ORIEN_U_X_ROOT
;... S Y(ORIEN_";"_ROOT)=Y(ORIEN_";"_ROOT)_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,2)_U_$S(ORSRC=2:1,1:ORSRC)
;.. S XP=X F S XP=$O(@ROOT@(XP)) Q:XP="" Q:$E(XP,1,$L(X))'=X D
;... I ORSRC=1,XP="OTHER ALLERGY/ADVERSE REACTION" Q ;don't send this entry
;... S ORIEN=$O(@ROOT@(XP,0))
;... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.82,.01,ORIEN_",") Q ;233 Is term active?
;... I ORSRC=2 S:'$D(Y(ORIEN_";"_ROOT)) CNT=CNT+1,Y(ORIEN_";"_ROOT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_XP_">"_ROOT ; partial matches
;... I ORSRC'=2 S:'$D(Y(ORIEN_";"_ROOT)) CNT=CNT+1,Y(ORIEN_";"_ROOT)=ORIEN_U_XP_ROOT
;... S:'$D(Y(ORIEN_";"_ROOT)) Y(ORIEN_";"_ROOT)=Y(ORIEN_";"_ROOT)_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,2)_U_$S(ORSRC=2:1,1:ORSRC)
;.. I (ORSRC>2),(ORSRC'=4),(ORSRC'=5),(ORSRC'=6) D
;.. N CODE,LIST,VAL,NAME
;.. S CODE=$S(ORSRC=3:"S VAL=$$TGTOG2^PSNAPIS(X,.LIST)",ORSRC=4:"D TRDNAME(X,.LIST)",ORSRC=7:"D INGSRCH(X,.LIST)",ORSRC=8:"D CLASRCH(X,.LIST)",1:"") Q:'$L(CODE)
;.. X CODE I $D(LIST) S ORIEN=0 F S ORIEN=$O(LIST(ORIEN)) Q:'ORIEN D
;... S NAME=$P(LIST(ORIEN),U,2)
;... Q:$E($P(LIST(ORIEN),U,2),1,$L(X))'=X
;... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID($S(ORSRC=3:50.6,(ORSRC=4):50.6,ORSRC=7:50.416,ORSRC=8:50.605,1:0),.01,ORIEN_",") Q
;... S:'$D(Y(ORIEN_";"_ROOT)) CNT=CNT+1,Y(ORIEN_";"_ROOT)=ORIEN_U_NAME_ROOT_U_"D"_U_ORSRC
;.. I ORSRC=4 D
;.. N CODE,LIST,VAL,NAME
;.. S CODE="D TRDNAME(X,.LIST)"
;.. X CODE I $D(LIST) S ORIEN=0 F S ORIEN=$O(LIST(ORIEN)) Q:'ORIEN D
;... S NAME=$P(LIST(ORIEN),U,2)
;... Q:$E($P(LIST(ORIEN),U,2),1,$L(X))'=X
;... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(50.6,.01,+LIST(ORIEN)_",") Q
;... S:'$D(Y(ORIEN_";"_ROOT)) CNT=CNT+1,Y(ORIEN_";"_ROOT)=+LIST(ORIEN)_U_NAME_ROOT_U_"D"_U_ORSRC
;S CNT=""
;F S CNT=$O(Y(CNT)) Q:CNT="" D
;. K ALLERGY
;. S ALLITEM=$G(Y(CNT))
;. I Y(CNT)["^TOP^+" Q
;. I Y(CNT)'["^TOP^+" D
;.. S ALLERGY("localId")=$P(ALLITEM,"^",1)
;.. S ALLERGY("name")=$P(ALLITEM,"^",2)
;.. S ALLERGY("root")=$P(ALLITEM,"^",3)
;.. S ALLERGY("uid")=$$SETUID^HMPUTILS("allergy-list",,ALLERGY("localId")_";"_$TR(ALLERGY("root"),"""","")) ;set the uid string
;.. S HMPCNT=$G(HMPCNT)+1 D ADD^HMPEF("ALLERGY") S HMPLAST=HMPCNT
;.. Q
;. Q
;S HMPFINI=1
;K X,Y
Q
;
VTYPE ; ;VITALS TYPE
N IEN
S (HMPCNT,HMPI,HMPLAST,IEN)=0
F S IEN=$O(^GMRD(120.51,IEN)) Q:IEN=""!(IEN'?1N.N) D
. S VTYPE("localId")=IEN
. S VTYPE("name")=$P(^GMRD(120.51,IEN,0),"^",1)
. S VTYPE("abbreviation")=$P(^GMRD(120.51,IEN,0),"^",2)
. S VTYPE("rate")=$P(^GMRD(120.51,IEN,0),"^",4)
. I VTYPE("rate")]"" S VTYPE("rate")=$S(VTYPE("rate")=1:"YES",1:"NO")
. S VTYPE("pce")=$P(^GMRD(120.51,IEN,0),"^",7)
. S VTYPE("vuid")="urn:va:vuid:"_$P($G(^GMRD(120.51,IEN,"VUID")),"^",1)
. S VTYPE("masterVuid")=$P($G(^GMRD(120.51,IEN,"VUID")),"^",2)
. I VTYPE("masterVuid")]"" S VTYPE("masterVuid")=$S(VTYPE("masterVuid")=1:"YES",1:"NO")
. S VTYPE("effective")=$P($G(^GMRD(120.51,IEN,"TERMSTATUS",1,0)),"^",1)
. I VTYPE("effective")]"" S VTYPE("effective")=$$JSONDT^HMPUTILS(VTYPE("effective"))
. S VTYPE("status")=$P($G(^GMRD(120.51,IEN,"TERMSTATUS",1,0)),"^",2)
. I VTYPE("status")]"" S VTYPE("status")=$S(VTYPE("status")=1:"ACTIVE",1:"INACTIVE")
. S VTYPE("uid")=$$SETUID^HMPUTILS("vital-type",,VTYPE("localId"))
. S HMPCNT=HMPCNT+1 D ADD^HMPEF("VTYPE") S HMPLAST=HMPCNT
S HMPFINI=1
K VTYPE
Q
;
VQUAL ; VITALS QUALIFIER
N IEN,I
S (HMPCNT,HMPI,HMPLAST,IEN)=0
F S IEN=$O(^GMRD(120.52,IEN)) Q:IEN=""!(IEN'?1N.N) D
. S VQUAL("localId")=IEN
. S VQUAL("synonym")=$P(^GMRD(120.52,IEN,0),"^",2)
. S I=0
. K VQUAL("vtype") ;ejk - stop bleed over from previous extracts.
. F S I=$O(^GMRD(120.52,IEN,1,I)) Q:I=""!(I'?1N.N) D
.. S VQUAL("vtype",I,"vitalType")=$P($G(^GMRD(120.52,IEN,1,I,0)),"^",1)
.. S VQUAL("vtype",I,"category")=$P($G(^GMRD(120.52,IEN,1,I,0)),"^",2)
.. ;ejk DE294 - vital type and vital category need to be presented as urn entries and not the name
.. ;I VQUAL("vtype",I,"vitalType")]"" S VQUAL("vtype",I,"vitalType")=$P($G(^GMRD(120.51,I,0)),"^",1)
.. ;I VQUAL("vtype",I,"category")]"" S VQUAL("vtype",I,"category")=$P($G(^GMRD(120.53,I,0)),"^",1)
.. I VQUAL("vtype",I,"vitalType")]"" S VQUAL("vtype",I,"vitalType")=$$SETUID^HMPUTILS("vital-type",,VQUAL("vtype",I,"vitalType"))
.. I VQUAL("vtype",I,"category")]"" S VQUAL("vtype",I,"category")=$$SETUID^HMPUTILS("vital-category",,VQUAL("vtype",I,"category"))
.. Q
. S VQUAL("vuid")="urn:va:vuid:"_$P($G(^GMRD(120.52,IEN,"VUID")),"^",1)
. S VQUAL("masterVuid")=$P($G(^GMRD(120.52,IEN,"VUID")),"^",2)
. I VQUAL("masterVuid")]"" S VQUAL("masterVuid")=$S(VQUAL("masterVuid")=1:"YES",1:"NO")
. S VQUAL("effectiveDate")=$P($G(^GMRD(120.52,IEN,"TERMSTATUS",1,0)),"^",1)
. I VQUAL("effectiveDate")]"" S VQUAL("effectiveDate")=$$JSONDT^HMPUTILS(VQUAL("effectiveDate"))
. S VQUAL("status")=$P($G(^GMRD(120.52,IEN,"TERMSTATUS",1,0)),"^",2)
. I VQUAL("status")]"" S VQUAL("status")=$S(VQUAL("status")=1:"ACTIVE",1:"INACTIVE")
. S VQUAL("uid")=$$SETUID^HMPUTILS("vital-qualifier",,VQUAL("localId"))
. S VQUAL("qualifier")=$$SETUID^HMPUTILS("vital-qualifier",,VQUAL("localId"))
. ;ejk DE295 do not include qualifier if it is the same value as the uid
. I VQUAL("uid")=VQUAL("qualifier") K VQUAL("qualifier")
. S HMPCNT=HMPCNT+1 D ADD^HMPEF("VQUAL") S HMPLAST=HMPCNT
S HMPFINI=1
K VQUAL
Q
;
VCAT ;VITALS CATAGORY
N IEN,I
S (HMPCNT,HMPI,HMPLAST,IEN)=0
F S IEN=$O(^GMRD(120.53,IEN)) Q:IEN=""!(IEN'?1N.N) D
. S VCAT("localId")=IEN
. I $P($G(^GMRD(120.53,IEN,0)),"^",1)]"" S VCAT("category")=$P(^GMRD(120.53,IEN,0),"^",1)
. I $P($G(^GMRD(120.53,IEN,0)),"^",2)]"" S VCAT("synonym")=$P(^GMRD(120.53,IEN,0),"^",2)
. I $G(VCAT("synonym"))="" K VCAT("synonym")
. S I=0
. ;EJK - kill off vtype array to stop inheriting values from previous extracts
. K VCAT("vtype")
. F S I=$O(^GMRD(120.53,IEN,1,I)) Q:I=""!(I'?1N.N) D
.. ;ejk DE298 do not send null values.
.. I $P($G(^GMRD(120.53,IEN,1,I,0)),"^",1)]"" S VCAT("vtype",I,"vitalType")=$P($G(^GMRD(120.53,IEN,1,I,0)),"^",1)
.. I VCAT("vtype",I,"vitalType")]"" S VCAT("vtype",I,"vitalType")=$$SETUID^HMPUTILS("vital-type",,VCAT("vtype",I,"vitalType"))
.. I $P($G(^GMRD(120.53,IEN,1,I,0)),"^",3)]"" S VCAT("vtype",I,"maxEntries")=$P($G(^GMRD(120.53,IEN,1,I,0)),"^",3)
.. I $P($G(^GMRD(120.53,IEN,1,I,0)),"^",5)]"" S VCAT("vtype",I,"printOrder")=$P($G(^GMRD(120.53,IEN,1,I,0)),"^",5)
.. I $P($G(^GMRD(120.53,IEN,1,I,0)),"^",6)]"" S VCAT("vtype",I,"editOrder")=$P($G(^GMRD(120.53,IEN,1,I,0)),"^",6)
.. I $P($G(^GMRD(120.53,IEN,1,I,0)),"^",7)]"" S VCAT("vtype",I,"defaultQualifier")=$P($G(^GMRD(120.53,IEN,1,I,0)),"^",7),VCAT("vtype",I,"defaultQualifier")=$$SETUID^HMPUTILS("vital-qualifier",,VCAT("vtype",I,"defaultQualifier"))
.. Q
. S VCAT("vuid")="urn:va:vuid:"_$P($G(^GMRD(120.53,IEN,"VUID")),"^",1)
. S VCAT("masterVuid")=$P($G(^GMRD(120.53,IEN,"VUID")),"^",2)
. I VCAT("masterVuid")]"" S VCAT("masterVuid")=$S(VCAT("masterVuid")=1:"YES",1:"NO")
. S VCAT("effectiveDate")=$P($G(^GMRD(120.53,IEN,"TERMSTATUS",1,0)),"^",1)
. I VCAT("effectiveDate")]"" S VCAT("effectiveDate")=$$JSONDT^HMPUTILS(VCAT("effectiveDate"))
. S VCAT("status")=$P($G(^GMRD(120.53,IEN,"TERMSTATUS",1,0)),"^",2)
. I VCAT("status")]"" S VCAT("status")=$S(VCAT("status")=1:"ACTIVE",1:"INACTIVE")
. S VCAT("uid")=$$SETUID^HMPUTILS("vital-category",,VCAT("localId"))
. S HMPCNT=HMPCNT+1 D ADD^HMPEF("VCAT") S HMPLAST=HMPCNT
. Q
S HMPFINI=1
K VCAT
Q
;
INGSRCH(NAME,LIST) ;
K ^TMP($J,"ORWDAL32")
D NAME^PSN50P41(NAME,"ORWDAL32")
I $D(^TMP($J,"ORWDAL32","P")) D
. N I S I="" F S I=$O(^TMP($J,"ORWDAL32","P",I)) Q:I="" D
.. N J S J=0 F S J=$O(^TMP($J,"ORWDAL32","P",I,J)) Q:'J S LIST(J)=J_U_I
K ^TMP($J,"ORWDAL32")
Q
CLASRCH(NAME,LIST) ;
K ^TMP($J,"ORWDAL32")
D C^PSN50P65(,NAME,"ORWDAL32")
I $D(^TMP($J,"ORWDAL32","C")) D
. N I S I="" F S I=$O(^TMP($J,"ORWDAL32","C",I)) Q:I="" D
.. N J S J=0 F S J=$O(^TMP($J,"ORWDAL32","C",I,J)) Q:'J S LIST(J)=J_U_$G(^TMP($J,"ORWDAL32",J,1))
K ^TMP($J,"ORWDAL32")
Q
TRDNAME(NAME,LIST) ;
K ^TMP($J,"ORWDAL32")
D ALL^PSN5067(,NAME,,"ORWDAL32")
I $D(^TMP($J,"ORWDAL32","B")) D
. N I S I="" F S I=$O(^TMP($J,"ORWDAL32","B",I)) Q:I="" D
.. N J,K S J=$O(^TMP($J,"ORWDAL32","B",I,0)) Q:'J S K=$$TGTOG^PSNAPIS(I),LIST(J)=K_U_$G(^TMP($J,"ORWDAL32",J,4))
K ^TMP($J,"ORWDAL32")
Q
FILENAME ; Display text of filenames for search treeview
;;VA Allergies File
;;VA Allergies File (Synonyms) SPACER ONLY - NOT DISPLAYED
;;National Drug File - Generic Drug Name
;;National Drug file - Trade Name
;;Local Drug File
;;Local Drug File (Synonyms) SPACER ONLY - NOT DISPLAYED
;;Drug Ingredients File
;;VA Drug Class File
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPCORD5 11465 printed Sep 23, 2025@19:29:04 Page 2
HMPCORD5 ;SLC/AGP,ASMR/EJK,RRB - Retrieved Orderable Items;Sep 1, 2016 17:27:27
+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 ; DE2497/RRB - Removed unused variable, HMP777
+5 ;
+6 ; DE6652 - JD - 9/1/16: Removed code behind synching sign-symptom domain for operational data.
+7 ; SIGNS tag.
+8 ;
+9 QUIT
+10 ;
IMMTYPE ;
+1 NEW ORWLST,ORDT,HMPIMM
+2 SET (ORWLST,ORDT)=""
+3 SET (HMPCNT,HMPLAST,HMPI)=0
+4 NEW IMM
+5 ;D IMMTYPE^ORWPCE2(.ORWLST,ORDT) ;use existing broker call ORWPCE GET IMMUNIZATION TYPE
+6 NEW IEN,CNT,BINDEX
SET (IEN,CNT)=0
+7 if '$GET(ORDT)
SET ORDT=DT
+8 ; ^AUTTIMM - IMMUNIZATION file #9999999.14, ***DBIA2454 subscription needed***
+9 FOR
SET IEN=$ORDER(^AUTTIMM(IEN))
if IEN=""!(IEN'?1N.N)
QUIT
Begin DoDot:1
+10 IF $DATA(^AUTTIMM(IEN,0))#2
IF +$PIECE(^(0),"^",7)=0
SET CNT=CNT+1
SET ORWLST(CNT)=IEN_"^"_$GET(^(0))
+11 QUIT
End DoDot:1
+12 SET IMM=""
SET HMPIMM=""
+13 FOR
SET IMM=$ORDER(ORWLST(IMM))
if IMM=""
QUIT
Begin DoDot:1
+14 ;get the ien for each item found
SET HMPIMM("localId")=$PIECE(ORWLST(IMM),"^",1)
+15 ;get the name for each item found
SET HMPIMM("name")=$PIECE(ORWLST(IMM),"^",2)
+16 ;get the mnemonic for each entry
SET HMPIMM("mnemonic")=$PIECE(ORWLST(IMM),"^",3)
+17 ;set the uid string
SET HMPIMM("uid")=$$SETUID^HMPUTILS("immunization",,HMPIMM("localId"))
+18 SET HMPCNT=HMPCNT+1
+19 ;add it to the JSON results array
DO ADD^HMPEF("HMPIMM")
SET HMPLAST=HMPCNT
+20 QUIT
End DoDot:1
+21 SET HMPFINI=1
+22 QUIT
+23 ;
ALLTYPE ; deprecated
+1 ;N ORX,ROOT,XP,CNT,ORFILE,ORSRC,ORIEN,ORREAX,ALLCNT,ALLLAST,ALLITEM
+2 ;S ORIEN=0,CNT=0,ORSRC=0,ORFILE="",ALLCNT=0,ALLLAST=0
+3 ;S X=""
+4 ;F ROOT="^GMRD(120.82)","^PSNDF(50.6)","^PSNDF(50.67)","^PSDRUG(""B"")","^PS(50.416)","^PS(50.605)" D
+5 ;F ROOT="^GMRD(120.82,""B"")","^GMRD(120.82,""D"")","^PSDRUG(""C"")","^PS(50.416,""P"")","^PS(50.605,""C"")",$$B^PSNAPIS,$$T^PSNAPIS,"^PSDRUG(""B"")" D
+6 ;F ROOT="^GMRD(120.82,""B"")","^PSDRUG(""C"")","^PS(50.416,""P"")","^PS(50.605,""C"")",$$B^PSNAPIS,$$T^PSNAPIS,"^PSDRUG(""B"")" D
+7 ;. S ORSRC=$G(ORSRC)+1,ORFILE=$P(ROOT,",",1)_")",ORSRC(ORSRC)=$P($T(FILENAME+ORSRC),";;",2)
+8 ;. I (ORSRC'=2),(ORSRC'=6) S:'$D(Y(ORIEN_";"_ROOT)) CNT=CNT+1,Y(ORIEN_";"_ROOT)=ORSRC_U_ORSRC(ORSRC)_U_U_U_"TOP"_U_"+"
+9 ;. I ORSRC=1!(ORSRC=2) D
+10 ;.. F S X=$O(@ROOT@(X)) Q:X="" D
+11 ;... I ORSRC=1,X="OTHER ALLERGY/ADVERSE REACTION" Q ;don't send this entry
+12 ;... S ORIEN=$O(@ROOT@(X,0))
+13 ;... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.82,.01,ORIEN_",") Q ;233 Is term active?
+14 ;... I ORSRC=2 S:'$D(Y(ORIEN_";"_ROOT)) CNT=CNT+1,Y(ORIEN_";"_ROOT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_X_">"_ROOT
+15 ;... I ORSRC'=2 S:'$D(Y(ORIEN_";"_ROOT)) CNT=CNT+1,Y(ORIEN_";"_ROOT)=ORIEN_U_X_ROOT
+16 ;... S Y(ORIEN_";"_ROOT)=Y(ORIEN_";"_ROOT)_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,2)_U_$S(ORSRC=2:1,1:ORSRC)
+17 ;.. S XP=X F S XP=$O(@ROOT@(XP)) Q:XP="" Q:$E(XP,1,$L(X))'=X D
+18 ;... I ORSRC=1,XP="OTHER ALLERGY/ADVERSE REACTION" Q ;don't send this entry
+19 ;... S ORIEN=$O(@ROOT@(XP,0))
+20 ;... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(120.82,.01,ORIEN_",") Q ;233 Is term active?
+21 ;... I ORSRC=2 S:'$D(Y(ORIEN_";"_ROOT)) CNT=CNT+1,Y(ORIEN_";"_ROOT)=ORIEN_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,1)_" <"_XP_">"_ROOT ; partial matches
+22 ;... I ORSRC'=2 S:'$D(Y(ORIEN_";"_ROOT)) CNT=CNT+1,Y(ORIEN_";"_ROOT)=ORIEN_U_XP_ROOT
+23 ;... S:'$D(Y(ORIEN_";"_ROOT)) Y(ORIEN_";"_ROOT)=Y(ORIEN_";"_ROOT)_U_$P($G(^GMRD(120.82,+ORIEN,0)),U,2)_U_$S(ORSRC=2:1,1:ORSRC)
+24 ;.. I (ORSRC>2),(ORSRC'=4),(ORSRC'=5),(ORSRC'=6) D
+25 ;.. N CODE,LIST,VAL,NAME
+26 ;.. S CODE=$S(ORSRC=3:"S VAL=$$TGTOG2^PSNAPIS(X,.LIST)",ORSRC=4:"D TRDNAME(X,.LIST)",ORSRC=7:"D INGSRCH(X,.LIST)",ORSRC=8:"D CLASRCH(X,.LIST)",1:"") Q:'$L(CODE)
+27 ;.. X CODE I $D(LIST) S ORIEN=0 F S ORIEN=$O(LIST(ORIEN)) Q:'ORIEN D
+28 ;... S NAME=$P(LIST(ORIEN),U,2)
+29 ;... Q:$E($P(LIST(ORIEN),U,2),1,$L(X))'=X
+30 ;... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID($S(ORSRC=3:50.6,(ORSRC=4):50.6,ORSRC=7:50.416,ORSRC=8:50.605,1:0),.01,ORIEN_",") Q
+31 ;... S:'$D(Y(ORIEN_";"_ROOT)) CNT=CNT+1,Y(ORIEN_";"_ROOT)=ORIEN_U_NAME_ROOT_U_"D"_U_ORSRC
+32 ;.. I ORSRC=4 D
+33 ;.. N CODE,LIST,VAL,NAME
+34 ;.. S CODE="D TRDNAME(X,.LIST)"
+35 ;.. X CODE I $D(LIST) S ORIEN=0 F S ORIEN=$O(LIST(ORIEN)) Q:'ORIEN D
+36 ;... S NAME=$P(LIST(ORIEN),U,2)
+37 ;... Q:$E($P(LIST(ORIEN),U,2),1,$L(X))'=X
+38 ;... I $L($T(SCREEN^XTID)) I $$SCREEN^XTID(50.6,.01,+LIST(ORIEN)_",") Q
+39 ;... S:'$D(Y(ORIEN_";"_ROOT)) CNT=CNT+1,Y(ORIEN_";"_ROOT)=+LIST(ORIEN)_U_NAME_ROOT_U_"D"_U_ORSRC
+40 ;S CNT=""
+41 ;F S CNT=$O(Y(CNT)) Q:CNT="" D
+42 ;. K ALLERGY
+43 ;. S ALLITEM=$G(Y(CNT))
+44 ;. I Y(CNT)["^TOP^+" Q
+45 ;. I Y(CNT)'["^TOP^+" D
+46 ;.. S ALLERGY("localId")=$P(ALLITEM,"^",1)
+47 ;.. S ALLERGY("name")=$P(ALLITEM,"^",2)
+48 ;.. S ALLERGY("root")=$P(ALLITEM,"^",3)
+49 ;.. S ALLERGY("uid")=$$SETUID^HMPUTILS("allergy-list",,ALLERGY("localId")_";"_$TR(ALLERGY("root"),"""","")) ;set the uid string
+50 ;.. S HMPCNT=$G(HMPCNT)+1 D ADD^HMPEF("ALLERGY") S HMPLAST=HMPCNT
+51 ;.. Q
+52 ;. Q
+53 ;S HMPFINI=1
+54 ;K X,Y
+55 QUIT
+56 ;
VTYPE ; ;VITALS TYPE
+1 NEW IEN
+2 SET (HMPCNT,HMPI,HMPLAST,IEN)=0
+3 FOR
SET IEN=$ORDER(^GMRD(120.51,IEN))
if IEN=""!(IEN'?1N.N)
QUIT
Begin DoDot:1
+4 SET VTYPE("localId")=IEN
+5 SET VTYPE("name")=$PIECE(^GMRD(120.51,IEN,0),"^",1)
+6 SET VTYPE("abbreviation")=$PIECE(^GMRD(120.51,IEN,0),"^",2)
+7 SET VTYPE("rate")=$PIECE(^GMRD(120.51,IEN,0),"^",4)
+8 IF VTYPE("rate")]""
SET VTYPE("rate")=$SELECT(VTYPE("rate")=1:"YES",1:"NO")
+9 SET VTYPE("pce")=$PIECE(^GMRD(120.51,IEN,0),"^",7)
+10 SET VTYPE("vuid")="urn:va:vuid:"_$PIECE($GET(^GMRD(120.51,IEN,"VUID")),"^",1)
+11 SET VTYPE("masterVuid")=$PIECE($GET(^GMRD(120.51,IEN,"VUID")),"^",2)
+12 IF VTYPE("masterVuid")]""
SET VTYPE("masterVuid")=$SELECT(VTYPE("masterVuid")=1:"YES",1:"NO")
+13 SET VTYPE("effective")=$PIECE($GET(^GMRD(120.51,IEN,"TERMSTATUS",1,0)),"^",1)
+14 IF VTYPE("effective")]""
SET VTYPE("effective")=$$JSONDT^HMPUTILS(VTYPE("effective"))
+15 SET VTYPE("status")=$PIECE($GET(^GMRD(120.51,IEN,"TERMSTATUS",1,0)),"^",2)
+16 IF VTYPE("status")]""
SET VTYPE("status")=$SELECT(VTYPE("status")=1:"ACTIVE",1:"INACTIVE")
+17 SET VTYPE("uid")=$$SETUID^HMPUTILS("vital-type",,VTYPE("localId"))
+18 SET HMPCNT=HMPCNT+1
DO ADD^HMPEF("VTYPE")
SET HMPLAST=HMPCNT
End DoDot:1
+19 SET HMPFINI=1
+20 KILL VTYPE
+21 QUIT
+22 ;
VQUAL ; VITALS QUALIFIER
+1 NEW IEN,I
+2 SET (HMPCNT,HMPI,HMPLAST,IEN)=0
+3 FOR
SET IEN=$ORDER(^GMRD(120.52,IEN))
if IEN=""!(IEN'?1N.N)
QUIT
Begin DoDot:1
+4 SET VQUAL("localId")=IEN
+5 SET VQUAL("synonym")=$PIECE(^GMRD(120.52,IEN,0),"^",2)
+6 SET I=0
+7 ;ejk - stop bleed over from previous extracts.
KILL VQUAL("vtype")
+8 FOR
SET I=$ORDER(^GMRD(120.52,IEN,1,I))
if I=""!(I'?1N.N)
QUIT
Begin DoDot:2
+9 SET VQUAL("vtype",I,"vitalType")=$PIECE($GET(^GMRD(120.52,IEN,1,I,0)),"^",1)
+10 SET VQUAL("vtype",I,"category")=$PIECE($GET(^GMRD(120.52,IEN,1,I,0)),"^",2)
+11 ;ejk DE294 - vital type and vital category need to be presented as urn entries and not the name
+12 ;I VQUAL("vtype",I,"vitalType")]"" S VQUAL("vtype",I,"vitalType")=$P($G(^GMRD(120.51,I,0)),"^",1)
+13 ;I VQUAL("vtype",I,"category")]"" S VQUAL("vtype",I,"category")=$P($G(^GMRD(120.53,I,0)),"^",1)
+14 IF VQUAL("vtype",I,"vitalType")]""
SET VQUAL("vtype",I,"vitalType")=$$SETUID^HMPUTILS("vital-type",,VQUAL("vtype",I,"vitalType"))
+15 IF VQUAL("vtype",I,"category")]""
SET VQUAL("vtype",I,"category")=$$SETUID^HMPUTILS("vital-category",,VQUAL("vtype",I,"category"))
+16 QUIT
End DoDot:2
+17 SET VQUAL("vuid")="urn:va:vuid:"_$PIECE($GET(^GMRD(120.52,IEN,"VUID")),"^",1)
+18 SET VQUAL("masterVuid")=$PIECE($GET(^GMRD(120.52,IEN,"VUID")),"^",2)
+19 IF VQUAL("masterVuid")]""
SET VQUAL("masterVuid")=$SELECT(VQUAL("masterVuid")=1:"YES",1:"NO")
+20 SET VQUAL("effectiveDate")=$PIECE($GET(^GMRD(120.52,IEN,"TERMSTATUS",1,0)),"^",1)
+21 IF VQUAL("effectiveDate")]""
SET VQUAL("effectiveDate")=$$JSONDT^HMPUTILS(VQUAL("effectiveDate"))
+22 SET VQUAL("status")=$PIECE($GET(^GMRD(120.52,IEN,"TERMSTATUS",1,0)),"^",2)
+23 IF VQUAL("status")]""
SET VQUAL("status")=$SELECT(VQUAL("status")=1:"ACTIVE",1:"INACTIVE")
+24 SET VQUAL("uid")=$$SETUID^HMPUTILS("vital-qualifier",,VQUAL("localId"))
+25 SET VQUAL("qualifier")=$$SETUID^HMPUTILS("vital-qualifier",,VQUAL("localId"))
+26 ;ejk DE295 do not include qualifier if it is the same value as the uid
+27 IF VQUAL("uid")=VQUAL("qualifier")
KILL VQUAL("qualifier")
+28 SET HMPCNT=HMPCNT+1
DO ADD^HMPEF("VQUAL")
SET HMPLAST=HMPCNT
End DoDot:1
+29 SET HMPFINI=1
+30 KILL VQUAL
+31 QUIT
+32 ;
VCAT ;VITALS CATAGORY
+1 NEW IEN,I
+2 SET (HMPCNT,HMPI,HMPLAST,IEN)=0
+3 FOR
SET IEN=$ORDER(^GMRD(120.53,IEN))
if IEN=""!(IEN'?1N.N)
QUIT
Begin DoDot:1
+4 SET VCAT("localId")=IEN
+5 IF $PIECE($GET(^GMRD(120.53,IEN,0)),"^",1)]""
SET VCAT("category")=$PIECE(^GMRD(120.53,IEN,0),"^",1)
+6 IF $PIECE($GET(^GMRD(120.53,IEN,0)),"^",2)]""
SET VCAT("synonym")=$PIECE(^GMRD(120.53,IEN,0),"^",2)
+7 IF $GET(VCAT("synonym"))=""
KILL VCAT("synonym")
+8 SET I=0
+9 ;EJK - kill off vtype array to stop inheriting values from previous extracts
+10 KILL VCAT("vtype")
+11 FOR
SET I=$ORDER(^GMRD(120.53,IEN,1,I))
if I=""!(I'?1N.N)
QUIT
Begin DoDot:2
+12 ;ejk DE298 do not send null values.
+13 IF $PIECE($GET(^GMRD(120.53,IEN,1,I,0)),"^",1)]""
SET VCAT("vtype",I,"vitalType")=$PIECE($GET(^GMRD(120.53,IEN,1,I,0)),"^",1)
+14 IF VCAT("vtype",I,"vitalType")]""
SET VCAT("vtype",I,"vitalType")=$$SETUID^HMPUTILS("vital-type",,VCAT("vtype",I,"vitalType"))
+15 IF $PIECE($GET(^GMRD(120.53,IEN,1,I,0)),"^",3)]""
SET VCAT("vtype",I,"maxEntries")=$PIECE($GET(^GMRD(120.53,IEN,1,I,0)),"^",3)
+16 IF $PIECE($GET(^GMRD(120.53,IEN,1,I,0)),"^",5)]""
SET VCAT("vtype",I,"printOrder")=$PIECE($GET(^GMRD(120.53,IEN,1,I,0)),"^",5)
+17 IF $PIECE($GET(^GMRD(120.53,IEN,1,I,0)),"^",6)]""
SET VCAT("vtype",I,"editOrder")=$PIECE($GET(^GMRD(120.53,IEN,1,I,0)),"^",6)
+18 IF $PIECE($GET(^GMRD(120.53,IEN,1,I,0)),"^",7)]""
SET VCAT("vtype",I,"defaultQualifier")=$PIECE($GET(^GMRD(120.53,IEN,1,I,0)),"^",7)
SET VCAT("vtype",I,"defaultQualifier")=$$SETUID^HMPUTILS("vital-qualifier",,VCAT("vtype",I,"defaultQualifier"))
+19 QUIT
End DoDot:2
+20 SET VCAT("vuid")="urn:va:vuid:"_$PIECE($GET(^GMRD(120.53,IEN,"VUID")),"^",1)
+21 SET VCAT("masterVuid")=$PIECE($GET(^GMRD(120.53,IEN,"VUID")),"^",2)
+22 IF VCAT("masterVuid")]""
SET VCAT("masterVuid")=$SELECT(VCAT("masterVuid")=1:"YES",1:"NO")
+23 SET VCAT("effectiveDate")=$PIECE($GET(^GMRD(120.53,IEN,"TERMSTATUS",1,0)),"^",1)
+24 IF VCAT("effectiveDate")]""
SET VCAT("effectiveDate")=$$JSONDT^HMPUTILS(VCAT("effectiveDate"))
+25 SET VCAT("status")=$PIECE($GET(^GMRD(120.53,IEN,"TERMSTATUS",1,0)),"^",2)
+26 IF VCAT("status")]""
SET VCAT("status")=$SELECT(VCAT("status")=1:"ACTIVE",1:"INACTIVE")
+27 SET VCAT("uid")=$$SETUID^HMPUTILS("vital-category",,VCAT("localId"))
+28 SET HMPCNT=HMPCNT+1
DO ADD^HMPEF("VCAT")
SET HMPLAST=HMPCNT
+29 QUIT
End DoDot:1
+30 SET HMPFINI=1
+31 KILL VCAT
+32 QUIT
+33 ;
INGSRCH(NAME,LIST) ;
+1 KILL ^TMP($JOB,"ORWDAL32")
+2 DO NAME^PSN50P41(NAME,"ORWDAL32")
+3 IF $DATA(^TMP($JOB,"ORWDAL32","P"))
Begin DoDot:1
+4 NEW I
SET I=""
FOR
SET I=$ORDER(^TMP($JOB,"ORWDAL32","P",I))
if I=""
QUIT
Begin DoDot:2
+5 NEW J
SET J=0
FOR
SET J=$ORDER(^TMP($JOB,"ORWDAL32","P",I,J))
if 'J
QUIT
SET LIST(J)=J_U_I
End DoDot:2
End DoDot:1
+6 KILL ^TMP($JOB,"ORWDAL32")
+7 QUIT
CLASRCH(NAME,LIST) ;
+1 KILL ^TMP($JOB,"ORWDAL32")
+2 DO C^PSN50P65(,NAME,"ORWDAL32")
+3 IF $DATA(^TMP($JOB,"ORWDAL32","C"))
Begin DoDot:1
+4 NEW I
SET I=""
FOR
SET I=$ORDER(^TMP($JOB,"ORWDAL32","C",I))
if I=""
QUIT
Begin DoDot:2
+5 NEW J
SET J=0
FOR
SET J=$ORDER(^TMP($JOB,"ORWDAL32","C",I,J))
if 'J
QUIT
SET LIST(J)=J_U_$GET(^TMP($JOB,"ORWDAL32",J,1))
End DoDot:2
End DoDot:1
+6 KILL ^TMP($JOB,"ORWDAL32")
+7 QUIT
TRDNAME(NAME,LIST) ;
+1 KILL ^TMP($JOB,"ORWDAL32")
+2 DO ALL^PSN5067(,NAME,,"ORWDAL32")
+3 IF $DATA(^TMP($JOB,"ORWDAL32","B"))
Begin DoDot:1
+4 NEW I
SET I=""
FOR
SET I=$ORDER(^TMP($JOB,"ORWDAL32","B",I))
if I=""
QUIT
Begin DoDot:2
+5 NEW J,K
SET J=$ORDER(^TMP($JOB,"ORWDAL32","B",I,0))
if 'J
QUIT
SET K=$$TGTOG^PSNAPIS(I)
SET LIST(J)=K_U_$GET(^TMP($JOB,"ORWDAL32",J,4))
End DoDot:2
End DoDot:1
+6 KILL ^TMP($JOB,"ORWDAL32")
+7 QUIT
FILENAME ; Display text of filenames for search treeview
+1 ;;VA Allergies File
+2 ;;VA Allergies File (Synonyms) SPACER ONLY - NOT DISPLAYED
+3 ;;National Drug File - Generic Drug Name
+4 ;;National Drug file - Trade Name
+5 ;;Local Drug File
+6 ;;Local Drug File (Synonyms) SPACER ONLY - NOT DISPLAYED
+7 ;;Drug Ingredients File
+8 ;;VA Drug Class File
+9 ;;
