BIUTL2 ;IHS/CMI/MWR - UTIL: ZIS, PATH, ERRCODE; MAY 10, 2010
;;8.5;IMMUNIZATION;**14**;AUG 01,2017
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; UTILITY: ZIS, ERROR CODE, VACCINE NAME & GROUP,
;; MAX SERIES#, LOT DFLT, CASE MGR DFLT, VIS DATE DFLT.
;; PATCH 1: Do not provide default Lot Number if Lot Number is restricted
;; to a site and user's DUZ(2) does not match the site. LOTDEF+19
;; PATCH 7: Changes to accommodate new TCH Forecaster HL7TX+16
;; PATCH 8: Changes to accommodate new TCH Forecaster HL7TX+16, MINAGE+6
;; PATCH 14: Update notes. RISKP+0
;
;
;----------
ERRCD(BIIEN,BITEXT,BIDISPL,BIABBRV) ;EP
;---> Display Error Code from BI TABLE ERROR CODE File.
;---> Parameters:
; 1 - BIIEN (req) IEN of Error Code in ^BIERR(.
; 2 - BITEXT (ret) Text of Error Code.
; 3 - BIDISPL (opt) BIDISPL=1 if Error Code Text SHOULD BE displayed here.
; 4 - BIABBRV (opt) BIABBRV=1 return Abbreviated Error Text (<20 chars).
;
;---> Set BITEXT=Text of Error Code.
D
.I '$G(BIIEN) D Q
..I $G(BIABBRV) S BITEXT="No Error Code" Q
..S BITEXT="Error Code not provided by software."
.;
.I '$D(^BIERR(BIIEN,0)) D Q
..I $G(BIABBRV) S BITEXT="No Error Code" Q
..S BITEXT="Error Code does not exist in BI TABLE ERROR CODE File."
.;
.I $G(BIABBRV) S BITEXT=$P(^BIERR(BIIEN,0),"^",3) Q
.S BITEXT=$P(^BIERR(BIIEN,0),"^",2)_" #"_BIIEN
;
;---> Display Error Code Text.
D:$G(BIDISPL)
.N BICRT S BICRT=$S(($E($G(IOST))="C")!($G(IOST)["BROWSER"):1,1:0)
.W !!?3,BITEXT
.W:'BICRT @IOF D:BICRT DIRZ^BIUTL3()
;
;---> Not used for now.
;D EN^DDIOL("* "_BITEXT,"","!!?3"),DIRZ^BIUTL3()
Q
;
;
;----------
VNAME(IEN,LONG) ;EP
;---> Return the Short, Long, or Full Name for a Vaccine.
;---> Parameters:
; 1 - IEN (req) IEN of Vaccine.
; 2 - LONG (opt) 0/null=Short Name; 1=Long Name; 2=Full Name;
; 3="ShortName (LongName)."
;
Q:'$G(IEN) "NO IEN"
Q:'$D(^AUTTIMM(IEN,0)) "UNKNOWN"
Q:$G(LONG)=1 $P(^AUTTIMM(IEN,0),"^")
Q:$G(LONG)=2 $P($G(^AUTTIMM(IEN,1)),"^",14)
Q:$G(LONG)=3 " "_$P(^AUTTIMM(IEN,0),"^",2)_" ("_$P(^AUTTIMM(IEN,0),"^")_") "
Q $P(^AUTTIMM(IEN,0),"^",2)
;
;
;----------
MNAME(IEN,MVX) ;EP
;---> Return Manufacturer Name or MVX Code.
;---> Parameters:
; 1 - IEN (req) IEN of Manufacturer.
; 2 - MVX (opt) If MVX=1, return MVX Code
;
Q:'$G(IEN) "NO IEN"
Q:'$D(^AUTTIMAN(IEN,0)) $S($G(MVX):"UNK",1:"UNKNOWN")
Q:$G(MVX)=1 $P(^AUTTIMAN(IEN,0),"^",2)
Q $P(^AUTTIMAN(IEN,0),"^")
;
;
;----------
CODE(IEN,TYPE) ;EP
;---> Return the HL7-CVX, CPT, ICD Diagnosis, or ICD Procedure Code
;---> for a Vaccine.
;---> Parameters:
; 1 - IEN (req) IEN of Vaccine.
; 2 - TYPE (opt) TYPE of Code to return:
; 1=HL7-CVX (also default)
; 2=CPT
; 3=ICD Diagnosis
; 4=ICD Procedure
; 5=Volume Default
; 6=HL7-CVX w/leading zero
;
Q:'$G(IEN) "NO IEN"
Q:'$D(^AUTTIMM(IEN,0)) "UNKNOWN"
;
Q:$G(TYPE)=2 $P(^AUTTIMM(IEN,0),"^",11)
Q:$G(TYPE)=3 $P(^AUTTIMM(IEN,0),"^",14)
Q:$G(TYPE)=4 $P(^AUTTIMM(IEN,0),"^",15)
Q:$G(TYPE)=5 $P(^AUTTIMM(IEN,0),"^",18)
N X S X=$P(^AUTTIMM(IEN,0),"^",3)
I $G(TYPE)=6,$L(X)=1 S X=0_X
Q X
;
;
;----------
IMMVG(BIIEN,Z) ;EP
;---> For a particular Vaccine, return its Vaccine Group Information.
;---> (Note: Vaccine Group is also called "Series Type."
;---> .
;---> Parameters:
; 1 - BIIEN (req) IEN in of Vaccine in IMMUNIZATION File #9999999.14.
; 2 - Z (opt) If Z=1, return Vaccine Group FULL NAME.
; If Z=2, return Vaccine Group IEN (default if no Z).
; If Z=3, return Vaccine Group Forecast indicator:
; 1=ON, 0=OFF
; If Z=4, return Display Order for reports.
; If Z=5, return SHORT NAME of Vaccine Group.
;
;---> Default: Return IEN of Vaccine Group.
S:'$G(Z) Z=2
N BIVG,BIVG0
;
;---> If any values or pointers are null, set Vaccine Group IEN=12: "Other".
D
.I '$G(BIIEN) S BIVG=12 Q
.I '$D(^AUTTIMM(BIIEN,0)) S BIVG=12 Q
.S BIVG=$P(^AUTTIMM(BIIEN,0),U,9)
.S:'BIVG BIVG=12
;
I Z=2 Q BIVG
Q $$VGROUP(BIVG,Z)
;
;
;----------
VGROUP(BIVG,Z) ;EP
;---> Return Vaccine Group or ("Series Type") or Information
;---> for a particular Vaccine Group.
;---> Parameters:
; 1 - BIVG (req) IEN in BI TABLE VACCINE GROUP File #9002084.93.
; 2 - Z (opt) If Z=1, return Vaccine Group FULL NAME (default if no Z).
; If Z=3, return Vaccine Group Forecast indicator:
; 1=ON, 0=OFF
; If Z=4, return Display Order for reports.
; If Z=5, return SHORT NAME of Vaccine Group.
; If Z=6, return max doses in Quarterly/Two-Yr-Old Reports.
; If Z=7, return max doses in Adolescent Report.
; If Z=8, return Vaccine Group Two-Yr-Old Report indicator:
; 1=Yes,include; 0=No, exclude.
;
;---> If null, set Vaccine Group IEN=12: "Other".
S:'$G(BIVG) BIVG=12
S BIVG0=$G(^BISERT(BIVG,0))
S:BIVG0="" BIVG=12,BIVG0=$G(^BISERT(BIVG,0))
;
S:('$G(Z)) Z=1
I Z=3 Q +$P(BIVG0,U,5)
I Z=4 Q +$P(BIVG0,U,2)
I Z=5 Q $P(BIVG0,U,3)
I Z=6 Q $P(BIVG0,U,4)
I Z=7 Q $P(BIVG0,U,7)
I Z=8 Q $P(BIVG0,U,8)
Q $P(BIVG0,U)
;
;
;----------
HL7TX(BICVX,BIGRP) ;EP
;---> Return the IEN of a Vaccine, given its HL7 Code.
;---> If lookup fails, return 137 for "OTHER".
;---> Parameters:
; 1 - BICVX (req) CVX Code for this vaccine.
; 2 - BIGRP (opt) If BIGRP=1, return Vaccine Group IEN for this CVX.
;
I '$G(BICVX) S BICVX=999
I '$D(^AUTTIMM("C",BICVX)) S BICVX=999
N BIVIEN S BIVIEN=$O(^AUTTIMM("C",BICVX,0))
S:'BIVIEN BIVIEN=137
;---> Return Vaccine IEN for this CVX.
Q:'$G(BIGRP) BIVIEN
;---> Return Vaccine Group for this CVX.
;
;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
;---> If the Vaccine Group is null, return IEN for Group "OTHER".
;Q $P(^AUTTIMM(BIVIEN,0),"^",9)
N X S X=$P(^AUTTIMM(BIVIEN,0),"^",9)
S:'X X=12
Q X
;**********
;
;
;----------
VCOMPS(IEN) ;EP v8.0
;---> Return string of components IEN's for a Vaccine.
;---> Parameters:
; 1 - IEN (req) IEN of Vaccine.
;
Q:'$G(IEN) ""
Q:'$D(^AUTTIMM(IEN,0)) ""
N X S X=$P(^AUTTIMM(IEN,0),"^",21,26)
S X=$TR(X,"^",";")
Q X
;
;
;----------
LOTDEF(IEN) ;EP
;---> Return the IEN of the Default Lot# for a Vaccine.
;---> Parameters:
; 1 - IEN (req) IEN of Vaccine in IMMUNIZATION File (9999999.14).
;
Q:'$G(IEN) ""
Q:'$D(^AUTTIMM(IEN,0)) ""
N X,Y S X=$P(^AUTTIMM(IEN,0),"^",4)
;
;---> Quit if no Default Lot# stored.
Q:'X ""
;---> Quit if pointed to Lot# does not exist.
S Y=$G(^AUTTIML(X,0))
Q:Y="" ""
;---> Quit if this Lot# does NOT point back to this Vaccine.
Q:$P(Y,U,4)'=IEN ""
;---> Quit if this Lot# is INACTIVE.
Q:$P(Y,U,3) ""
;
;********** PATCH 1, v8.2.1, FEB 01,2008, IHS/CMI/MWR
;---> Quit if this Lot# has a Facility and User's DUZ(2) does not match.
Q:(($P(Y,U,14))&($P(Y,U,14)'=$G(DUZ(2)))) ""
;**********
;
;---> Return Default Lot# IEN.
Q X
;
;
;----------
LOTREQ(BIDUZ2) ;EP
;---> Return 1 if Lot#'s are required, 0 if not.
;---> Parameters:
; 1 - BIDUZ2 (req) User's DUZ(2)
;
Q $P($G(^BISITE(+$G(BIDUZ2),0)),U,9)
;
;
;----------
LOTLOW(BILIEN,BIDUZ2) ;EP
;---> Return the number of (remaining) doses of a Lot Number
;---> that will trigger a Low Supply Alert.
;---> If not set for this site, 50 will be returned.
;---> Parameters:
; 1 - BILIEN (req) IEN of Lot Number in ^AUTTIML.
; 2 - BIDUZ2 (req) User's DUZ(2)
; vvv83
N X
D
.S X=$P($G(^AUTTIML(+BILIEN,0)),U,15) Q:X
.S X=$P($G(^BISITE(+$G(BIDUZ2),0)),U,25)
S:(X="") X=50
Q X
;
;
;----------
FORECAS(BIDUZ2) ;EP
;---> Return 1 if Forecasting is enabled.
;---> Parameters:
; 1 - BIDUZ2 (req) User's DUZ(2)
;
Q $P($G(^BISITE(+$G(BIDUZ2),0)),U,11)
;
;
;----------
INPTCHK(BIDUZ2) ;EP
;---> Return 1 if Inpatient Visit Check is enabled.
;---> Parameters:
; 1 - BIDUZ2 (req) User's DUZ(2)
;
Q $P($G(^BISITE(+$G(BIDUZ2),0)),U,23)
;
;
;********** PATCH 14, v8.5, AUG 01,2017, IHS/CMI/MWR
;---> Update notes below.
;----------
RISKP(BIDUZ2) ;EP - Risk Factor check (and smoking).
;---> Risk Parameter: 0 - None, 1 - Pneumo for High Risk history,
;---> 2 - Hep B for Diabetes Mellitus, 3 - Hep A and Hep B for CLD/Hep C
;---> 9 - adds Smoking Factors.
;---> Parameters:
; 1 - BIDUZ2 (req) User's DUZ(2)
;
Q +$P($G(^BISITE(+$G(BIDUZ2),0)),U,19)
;**********
;
;
;----------
IMPCPT(BIDUZ2) ;EP
;---> Return 1 if Import of CPT-coded Visits is enabled.
;---> Parameters:
; 1 - BIDUZ2 (req) User's DUZ(2)
;
Q $P($G(^BISITE(+$G(BIDUZ2),0)),U,20)
;
;
;----------
VISMNU(BIDUZ2) ;EP
;---> Visit Selection Menu Parameter: Return 1 to display a menu of matching
;---> Visits, if any; return 0 to automatically create or link Visits.
;---> Parameters:
; 1 - BIDUZ2 (req) User's DUZ(2)
;
Q +$P($G(^BISITE(+$G(BIDUZ2),0)),U,28)
;
;
;----------
CMGRACT(BICMGR) ;EP
;---> Return 1 if the Case Manager is INACTIVE.
;---> Parameters:
; 1 - BICMGR (req) IEN of Case Manager.
;
Q:'$G(BICMGR) 1
Q:'$D(^BIMGR(BICMGR,0)) 1
Q $P(^BIMGR(BICMGR,0),U,2)
;
;
;----------
CMGRDEF(DUZ2,X) ;EP
;---> Return Default Case Manager for this site.
;---> Parameters:
; 1 - DUZ2 (req) User's DUZ(2)
; 2 - X (opt) X=1 to return TEXT of default Case Manager name.
;
Q:'$G(DUZ2) ""
N Y S Y=$P($G(^BISITE(DUZ2,0)),U,2)
Q:'Y ""
Q:'$D(^BIMGR(Y,0)) ""
Q:'$G(X) Y
Q:$$CMGRACT(Y) $E($$PERSON^BIUTL1(Y),1,20)_" * INACTIVE!"
Q $$PERSON^BIUTL1(Y)
;
;
;----------
DEFLET(DUZ2,X,Z) ;EP
;---> Return Default Letters (Standard Due Letter,
;---> Official Imm Record).
;---> Parameters:
; 1 - DUZ2 (req) User's DUZ(2)
; 2 - X (opt) X=1 to return TEXT of default Due Letter.
; 3 - Z (opt) Z="" returns Standard Due Letter.
; Z=1 returns Official Immunization Record.
;
Q:'$G(DUZ2) ""
N Y S Y=$P($G(^BISITE(DUZ2,0)),U,$S($G(Z):13,1:4))
Q:'$G(X) Y
Q:'Y ""
Q $P($G(^BILET(Y,0)),U)
;
;
;----------
MINDAYS(DUZ2) ;EP
;---> Return Default Minimum Days Since Last Letter sent
;---> for this site.
;---> Parameters:
; 1 - DUZ2 (req) User's DUZ(2)
;
Q:'$G(DUZ2) 60
N Y S Y=$P($G(^BISITE(DUZ2,0)),U,5)
Q:Y="" 60
Q Y
;
;
;----------
MINAGE(DUZ2) ;EP
;---> Return parameter to forecast immunizations due at either the
;---> Minimum Acceptable Age or at the Recommended Age for this site.
;---> Parameters:
; 1 - DUZ2 (req) User's DUZ(2)
;
;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
;---> Change returned value to 1 or 0 to accommodate new forecaster.
Q:'$G(DUZ2) 0
Q:($P($G(^BISITE(DUZ2,0)),U,7)="A") 1
Q 0
;**********
;
;
;----------
RULES(DUZ2) ;EP
;---> Return parameter indicating which set of Immserve Forecasting
;---> Rules is being used (passed to Immserve).
;---> Parameters:
; 1 - DUZ2 (req) User's DUZ(2)
;
N Y S Y=$$VALIDRUL(DUZ2)
Q:'Y "IHS_1m18"
Q "IHS_"_Y
;
;
;----------
VALIDRUL(DUZ2) ;EP
;---> Return whether current Immserve Site Parameter is a valid choice.
;---> Return 0 is NOT a valid choice; otherwise return the numeric choice.
;---> Parameters:
; 1 - DUZ2 (req) User's DUZ(2)
;
Q:'$G(DUZ2) 0
N X,Y
S Y=$G(^BISITE(DUZ(2),0)),X=$P(Y,U,8)
;---> For a new set of Immserve Rules, change here below and $$RULES+10^BISITE2.
;---> Current valid choices are 1,2,3,4,5,11.
Q:((X<1)!(X>11)) 0
Q:((X>7)&(X<11)) 0
Q X_$S($P(Y,U,21):"g",1:"")_$S($P(Y,U,24)=2:"m26",1:"m18")
;
;
;----------
VISDEF(IEN) ;EP
;---> Return the Default Date of the Vaccine Information Statement
;---> (VIS) for this vaccine (Fileman format).
;---> Parameters:
; 1 - IEN (req) IEN of Vaccine in IMMUNIZATION File (9999999.14).
;
Q:'$G(IEN) ""
Q:'$D(^AUTTIMM(IEN,0)) ""
Q $P(^AUTTIMM(IEN,0),"^",13)
;
;
;----------
ZIS(BIPOP,BIQUE,BIDEF,BIPRMPT,BIMES) ;EP
;---> Call to ^%ZIS
;---> Parameters:
; 1 - BIPOP (ret) BIPOP=1 if POP=1 (fail or quit).
; 2 - BIQUE=1 (opt) SET=1 if job should be queueable.
; 3 - BIDEF=DEFAULT (opt) If exists, equals Default DEVICE.
; 4 - BIPRMPT (opt) If exists, equals PROMPT.
; 5 - BIMES (opt) A message to display if QUEUED.
;
;---> Example: D ZIS^BIUTL2(.BIPOP,1,"HOME")
;
ZIS1 ;EP for loop back from failed BIQUE.
S BIPOP=0
;
;---> BIPRMPT=BIPRMPT.
S %ZIS("A")=$S($D(BIPRMPT):BIPRMPT,1:" Select DEVICE: ")
;
;---> BIDEF=DEFAULT PRINTER.
;---> IF NO BIDEF, SET BIDEF="P" FOR CLOSEST PRINTER.
D
.I '$D(BIDEF) S %ZIS="P" Q
.S %ZIS("B")=BIDEF,%ZIS=""
;
;---> If BIQUE=1,job may be queued.
I $G(BIQUE)]"" I BIQUE S %ZIS=%ZIS_"Q"
;
W ! D ^%ZIS S:POP BIPOP=1
;---> Quit if BIPOP (DUOUT or DTOUT) or if not queued.
G:BIPOP!('$D(IO("Q"))) ZISEXIT
;
I IO=IO(0) W !?5,"Cannot queue to screen or slave printer!",! G ZIS1
;
;---> NEXT LINE: Line Label "ZISQ" added for entry where Device
;---> Info has already been adked and User queued output.
ZISQ ;EP
;---> NEXT LINES: Job was queued, therefore set BIPOP=1 so that the
;---> calling routine will quit (and let Taskman finish this job).
S BIPOP=1
I '$D(ZTRTN) D G ZISEXIT
.W !?5,*7,"NO ROUTINE NAMED FOR QUEUEING -- CONTACT PROGRAMMER."
I '$D(ZTDESC) S ZTDESC=ZTRTN
S BIMES=$S($D(BIMES):BIMES,1:"W !?5,""Request Queued."",!")
;
S ZTIO=$S($D(ION):ION,1:"")
I ZTIO]"" D
.I $D(IO("DOC")) S ZTIO=ZTIO_";"_IOST_";"_IO("DOC") Q
.S ZTIO=ZTIO_";"_IOST_";"_IOM_";"_IOSL
;
;---> Uncomment next line to suppress "Requested Start Time" question.
;S ZTDTH=$H
D ^%ZTLOAD,^%ZISC
X:$D(ZTQUEUED) BIMES H 2
;
ZISEXIT ;EP
K BIMES,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
Q
;
;
;----------
DFNCHECK() ;EP
;---> If BIDFN not supplied, set Error Code and quit.
I '$G(BIDFN) D ERRCD^BIUTL2(201,,1) Q 1
Q 0
;
;
;----------
DUZCHECK() ;EP
;---> If no BIDUZ2 (Site IEN), Set it equal to User's DUZ(2).
;---> If User's DUZ(2) fails, set Error Code and quit.
S:'$G(BIDUZ2) BIDUZ2=$G(DUZ(2))
I '$G(BIDUZ2) D ERRCD^BIUTL2(105,,1) Q 1
Q 0
;
;
VMAX(IEN) ;EP ;MWRZZZ REMOVE?
;---> Return the Maximum Dose# for a Vaccine.
;---> Parameters:
; 1 - IEN (req) IEN of Vaccine.
;
Q ""
Q $P(^AUTTIMM(IEN,0),"^",5)
BIUTL2 ;IHS/CMI/MWR - UTIL: ZIS, PATH, ERRCODE; MAY 10, 2010
+1 ;;8.5;IMMUNIZATION;**14**;AUG 01,2017
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; UTILITY: ZIS, ERROR CODE, VACCINE NAME & GROUP,
+4 ;; MAX SERIES#, LOT DFLT, CASE MGR DFLT, VIS DATE DFLT.
+5 ;; PATCH 1: Do not provide default Lot Number if Lot Number is restricted
+6 ;; to a site and user's DUZ(2) does not match the site. LOTDEF+19
+7 ;; PATCH 7: Changes to accommodate new TCH Forecaster HL7TX+16
+8 ;; PATCH 8: Changes to accommodate new TCH Forecaster HL7TX+16, MINAGE+6
+9 ;; PATCH 14: Update notes. RISKP+0
+10 ;
+11 ;
+12 ;----------
ERRCD(BIIEN,BITEXT,BIDISPL,BIABBRV) ;EP
+1 ;---> Display Error Code from BI TABLE ERROR CODE File.
+2 ;---> Parameters:
+3 ; 1 - BIIEN (req) IEN of Error Code in ^BIERR(.
+4 ; 2 - BITEXT (ret) Text of Error Code.
+5 ; 3 - BIDISPL (opt) BIDISPL=1 if Error Code Text SHOULD BE displayed here.
+6 ; 4 - BIABBRV (opt) BIABBRV=1 return Abbreviated Error Text (<20 chars).
+7 ;
+8 ;---> Set BITEXT=Text of Error Code.
+9 Begin DoDot:1
+10 IF '$GET(BIIEN)
Begin DoDot:2
+11 IF $GET(BIABBRV)
SET BITEXT="No Error Code"
QUIT
+12 SET BITEXT="Error Code not provided by software."
End DoDot:2
QUIT
+13 ;
+14 IF '$DATA(^BIERR(BIIEN,0))
Begin DoDot:2
+15 IF $GET(BIABBRV)
SET BITEXT="No Error Code"
QUIT
+16 SET BITEXT="Error Code does not exist in BI TABLE ERROR CODE File."
End DoDot:2
QUIT
+17 ;
+18 IF $GET(BIABBRV)
SET BITEXT=$PIECE(^BIERR(BIIEN,0),"^",3)
QUIT
+19 SET BITEXT=$PIECE(^BIERR(BIIEN,0),"^",2)_" #"_BIIEN
End DoDot:1
+20 ;
+21 ;---> Display Error Code Text.
+22 IF $GET(BIDISPL)
Begin DoDot:1
+23 NEW BICRT
SET BICRT=$SELECT(($EXTRACT($GET(IOST))="C")!($GET(IOST)["BROWSER"):1,1:0)
+24 WRITE !!?3,BITEXT
+25 IF 'BICRT
WRITE @IOF
IF BICRT
DO DIRZ^BIUTL3()
End DoDot:1
+26 ;
+27 ;---> Not used for now.
+28 ;D EN^DDIOL("* "_BITEXT,"","!!?3"),DIRZ^BIUTL3()
+29 QUIT
+30 ;
+31 ;
+32 ;----------
VNAME(IEN,LONG) ;EP
+1 ;---> Return the Short, Long, or Full Name for a Vaccine.
+2 ;---> Parameters:
+3 ; 1 - IEN (req) IEN of Vaccine.
+4 ; 2 - LONG (opt) 0/null=Short Name; 1=Long Name; 2=Full Name;
+5 ; 3="ShortName (LongName)."
+6 ;
+7 IF '$GET(IEN)
QUIT "NO IEN"
+8 IF '$DATA(^AUTTIMM(IEN,0))
QUIT "UNKNOWN"
+9 IF $GET(LONG)=1
QUIT $PIECE(^AUTTIMM(IEN,0),"^")
+10 IF $GET(LONG)=2
QUIT $PIECE($GET(^AUTTIMM(IEN,1)),"^",14)
+11 IF $GET(LONG)=3
QUIT " "_$PIECE(^AUTTIMM(IEN,0),"^",2)_" ("_$PIECE(^AUTTIMM(IEN,0),"^")_") "
+12 QUIT $PIECE(^AUTTIMM(IEN,0),"^",2)
+13 ;
+14 ;
+15 ;----------
MNAME(IEN,MVX) ;EP
+1 ;---> Return Manufacturer Name or MVX Code.
+2 ;---> Parameters:
+3 ; 1 - IEN (req) IEN of Manufacturer.
+4 ; 2 - MVX (opt) If MVX=1, return MVX Code
+5 ;
+6 IF '$GET(IEN)
QUIT "NO IEN"
+7 IF '$DATA(^AUTTIMAN(IEN,0))
QUIT $SELECT($GET(MVX):"UNK",1:"UNKNOWN")
+8 IF $GET(MVX)=1
QUIT $PIECE(^AUTTIMAN(IEN,0),"^",2)
+9 QUIT $PIECE(^AUTTIMAN(IEN,0),"^")
+10 ;
+11 ;
+12 ;----------
CODE(IEN,TYPE) ;EP
+1 ;---> Return the HL7-CVX, CPT, ICD Diagnosis, or ICD Procedure Code
+2 ;---> for a Vaccine.
+3 ;---> Parameters:
+4 ; 1 - IEN (req) IEN of Vaccine.
+5 ; 2 - TYPE (opt) TYPE of Code to return:
+6 ; 1=HL7-CVX (also default)
+7 ; 2=CPT
+8 ; 3=ICD Diagnosis
+9 ; 4=ICD Procedure
+10 ; 5=Volume Default
+11 ; 6=HL7-CVX w/leading zero
+12 ;
+13 IF '$GET(IEN)
QUIT "NO IEN"
+14 IF '$DATA(^AUTTIMM(IEN,0))
QUIT "UNKNOWN"
+15 ;
+16 IF $GET(TYPE)=2
QUIT $PIECE(^AUTTIMM(IEN,0),"^",11)
+17 IF $GET(TYPE)=3
QUIT $PIECE(^AUTTIMM(IEN,0),"^",14)
+18 IF $GET(TYPE)=4
QUIT $PIECE(^AUTTIMM(IEN,0),"^",15)
+19 IF $GET(TYPE)=5
QUIT $PIECE(^AUTTIMM(IEN,0),"^",18)
+20 NEW X
SET X=$PIECE(^AUTTIMM(IEN,0),"^",3)
+21 IF $GET(TYPE)=6
IF $LENGTH(X)=1
SET X=0_X
+22 QUIT X
+23 ;
+24 ;
+25 ;----------
IMMVG(BIIEN,Z) ;EP
+1 ;---> For a particular Vaccine, return its Vaccine Group Information.
+2 ;---> (Note: Vaccine Group is also called "Series Type."
+3 ;---> .
+4 ;---> Parameters:
+5 ; 1 - BIIEN (req) IEN in of Vaccine in IMMUNIZATION File #9999999.14.
+6 ; 2 - Z (opt) If Z=1, return Vaccine Group FULL NAME.
+7 ; If Z=2, return Vaccine Group IEN (default if no Z).
+8 ; If Z=3, return Vaccine Group Forecast indicator:
+9 ; 1=ON, 0=OFF
+10 ; If Z=4, return Display Order for reports.
+11 ; If Z=5, return SHORT NAME of Vaccine Group.
+12 ;
+13 ;---> Default: Return IEN of Vaccine Group.
+14 IF '$GET(Z)
SET Z=2
+15 NEW BIVG,BIVG0
+16 ;
+17 ;---> If any values or pointers are null, set Vaccine Group IEN=12: "Other".
+18 Begin DoDot:1
+19 IF '$GET(BIIEN)
SET BIVG=12
QUIT
+20 IF '$DATA(^AUTTIMM(BIIEN,0))
SET BIVG=12
QUIT
+21 SET BIVG=$PIECE(^AUTTIMM(BIIEN,0),U,9)
+22 IF 'BIVG
SET BIVG=12
End DoDot:1
+23 ;
+24 IF Z=2
QUIT BIVG
+25 QUIT $$VGROUP(BIVG,Z)
+26 ;
+27 ;
+28 ;----------
VGROUP(BIVG,Z) ;EP
+1 ;---> Return Vaccine Group or ("Series Type") or Information
+2 ;---> for a particular Vaccine Group.
+3 ;---> Parameters:
+4 ; 1 - BIVG (req) IEN in BI TABLE VACCINE GROUP File #9002084.93.
+5 ; 2 - Z (opt) If Z=1, return Vaccine Group FULL NAME (default if no Z).
+6 ; If Z=3, return Vaccine Group Forecast indicator:
+7 ; 1=ON, 0=OFF
+8 ; If Z=4, return Display Order for reports.
+9 ; If Z=5, return SHORT NAME of Vaccine Group.
+10 ; If Z=6, return max doses in Quarterly/Two-Yr-Old Reports.
+11 ; If Z=7, return max doses in Adolescent Report.
+12 ; If Z=8, return Vaccine Group Two-Yr-Old Report indicator:
+13 ; 1=Yes,include; 0=No, exclude.
+14 ;
+15 ;---> If null, set Vaccine Group IEN=12: "Other".
+16 IF '$GET(BIVG)
SET BIVG=12
+17 SET BIVG0=$GET(^BISERT(BIVG,0))
+18 IF BIVG0=""
SET BIVG=12
SET BIVG0=$GET(^BISERT(BIVG,0))
+19 ;
+20 IF ('$GET(Z))
SET Z=1
+21 IF Z=3
QUIT +$PIECE(BIVG0,U,5)
+22 IF Z=4
QUIT +$PIECE(BIVG0,U,2)
+23 IF Z=5
QUIT $PIECE(BIVG0,U,3)
+24 IF Z=6
QUIT $PIECE(BIVG0,U,4)
+25 IF Z=7
QUIT $PIECE(BIVG0,U,7)
+26 IF Z=8
QUIT $PIECE(BIVG0,U,8)
+27 QUIT $PIECE(BIVG0,U)
+28 ;
+29 ;
+30 ;----------
HL7TX(BICVX,BIGRP) ;EP
+1 ;---> Return the IEN of a Vaccine, given its HL7 Code.
+2 ;---> If lookup fails, return 137 for "OTHER".
+3 ;---> Parameters:
+4 ; 1 - BICVX (req) CVX Code for this vaccine.
+5 ; 2 - BIGRP (opt) If BIGRP=1, return Vaccine Group IEN for this CVX.
+6 ;
+7 IF '$GET(BICVX)
SET BICVX=999
+8 IF '$DATA(^AUTTIMM("C",BICVX))
SET BICVX=999
+9 NEW BIVIEN
SET BIVIEN=$ORDER(^AUTTIMM("C",BICVX,0))
+10 IF 'BIVIEN
SET BIVIEN=137
+11 ;---> Return Vaccine IEN for this CVX.
+12 IF '$GET(BIGRP)
QUIT BIVIEN
+13 ;---> Return Vaccine Group for this CVX.
+14 ;
+15 ;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
+16 ;---> If the Vaccine Group is null, return IEN for Group "OTHER".
+17 ;Q $P(^AUTTIMM(BIVIEN,0),"^",9)
+18 NEW X
SET X=$PIECE(^AUTTIMM(BIVIEN,0),"^",9)
+19 IF 'X
SET X=12
+20 QUIT X
+21 ;**********
+22 ;
+23 ;
+24 ;----------
VCOMPS(IEN) ;EP v8.0
+1 ;---> Return string of components IEN's for a Vaccine.
+2 ;---> Parameters:
+3 ; 1 - IEN (req) IEN of Vaccine.
+4 ;
+5 IF '$GET(IEN)
QUIT ""
+6 IF '$DATA(^AUTTIMM(IEN,0))
QUIT ""
+7 NEW X
SET X=$PIECE(^AUTTIMM(IEN,0),"^",21,26)
+8 SET X=$TRANSLATE(X,"^",";")
+9 QUIT X
+10 ;
+11 ;
+12 ;----------
LOTDEF(IEN) ;EP
+1 ;---> Return the IEN of the Default Lot# for a Vaccine.
+2 ;---> Parameters:
+3 ; 1 - IEN (req) IEN of Vaccine in IMMUNIZATION File (9999999.14).
+4 ;
+5 IF '$GET(IEN)
QUIT ""
+6 IF '$DATA(^AUTTIMM(IEN,0))
QUIT ""
+7 NEW X,Y
SET X=$PIECE(^AUTTIMM(IEN,0),"^",4)
+8 ;
+9 ;---> Quit if no Default Lot# stored.
+10 IF 'X
QUIT ""
+11 ;---> Quit if pointed to Lot# does not exist.
+12 SET Y=$GET(^AUTTIML(X,0))
+13 IF Y=""
QUIT ""
+14 ;---> Quit if this Lot# does NOT point back to this Vaccine.
+15 IF $PIECE(Y,U,4)'=IEN
QUIT ""
+16 ;---> Quit if this Lot# is INACTIVE.
+17 IF $PIECE(Y,U,3)
QUIT ""
+18 ;
+19 ;********** PATCH 1, v8.2.1, FEB 01,2008, IHS/CMI/MWR
+20 ;---> Quit if this Lot# has a Facility and User's DUZ(2) does not match.
+21 IF (($PIECE(Y,U,14))&($PIECE(Y,U,14)'=$GET(DUZ(2))))
QUIT ""
+22 ;**********
+23 ;
+24 ;---> Return Default Lot# IEN.
+25 QUIT X
+26 ;
+27 ;
+28 ;----------
LOTREQ(BIDUZ2) ;EP
+1 ;---> Return 1 if Lot#'s are required, 0 if not.
+2 ;---> Parameters:
+3 ; 1 - BIDUZ2 (req) User's DUZ(2)
+4 ;
+5 QUIT $PIECE($GET(^BISITE(+$GET(BIDUZ2),0)),U,9)
+6 ;
+7 ;
+8 ;----------
LOTLOW(BILIEN,BIDUZ2) ;EP
+1 ;---> Return the number of (remaining) doses of a Lot Number
+2 ;---> that will trigger a Low Supply Alert.
+3 ;---> If not set for this site, 50 will be returned.
+4 ;---> Parameters:
+5 ; 1 - BILIEN (req) IEN of Lot Number in ^AUTTIML.
+6 ; 2 - BIDUZ2 (req) User's DUZ(2)
+7 ; vvv83
+8 NEW X
+9 Begin DoDot:1
+10 SET X=$PIECE($GET(^AUTTIML(+BILIEN,0)),U,15)
IF X
QUIT
+11 SET X=$PIECE($GET(^BISITE(+$GET(BIDUZ2),0)),U,25)
End DoDot:1
+12 IF (X="")
SET X=50
+13 QUIT X
+14 ;
+15 ;
+16 ;----------
FORECAS(BIDUZ2) ;EP
+1 ;---> Return 1 if Forecasting is enabled.
+2 ;---> Parameters:
+3 ; 1 - BIDUZ2 (req) User's DUZ(2)
+4 ;
+5 QUIT $PIECE($GET(^BISITE(+$GET(BIDUZ2),0)),U,11)
+6 ;
+7 ;
+8 ;----------
INPTCHK(BIDUZ2) ;EP
+1 ;---> Return 1 if Inpatient Visit Check is enabled.
+2 ;---> Parameters:
+3 ; 1 - BIDUZ2 (req) User's DUZ(2)
+4 ;
+5 QUIT $PIECE($GET(^BISITE(+$GET(BIDUZ2),0)),U,23)
+6 ;
+7 ;
+8 ;********** PATCH 14, v8.5, AUG 01,2017, IHS/CMI/MWR
+9 ;---> Update notes below.
+10 ;----------
RISKP(BIDUZ2) ;EP - Risk Factor check (and smoking).
+1 ;---> Risk Parameter: 0 - None, 1 - Pneumo for High Risk history,
+2 ;---> 2 - Hep B for Diabetes Mellitus, 3 - Hep A and Hep B for CLD/Hep C
+3 ;---> 9 - adds Smoking Factors.
+4 ;---> Parameters:
+5 ; 1 - BIDUZ2 (req) User's DUZ(2)
+6 ;
+7 QUIT +$PIECE($GET(^BISITE(+$GET(BIDUZ2),0)),U,19)
+8 ;**********
+9 ;
+10 ;
+11 ;----------
IMPCPT(BIDUZ2) ;EP
+1 ;---> Return 1 if Import of CPT-coded Visits is enabled.
+2 ;---> Parameters:
+3 ; 1 - BIDUZ2 (req) User's DUZ(2)
+4 ;
+5 QUIT $PIECE($GET(^BISITE(+$GET(BIDUZ2),0)),U,20)
+6 ;
+7 ;
+8 ;----------
VISMNU(BIDUZ2) ;EP
+1 ;---> Visit Selection Menu Parameter: Return 1 to display a menu of matching
+2 ;---> Visits, if any; return 0 to automatically create or link Visits.
+3 ;---> Parameters:
+4 ; 1 - BIDUZ2 (req) User's DUZ(2)
+5 ;
+6 QUIT +$PIECE($GET(^BISITE(+$GET(BIDUZ2),0)),U,28)
+7 ;
+8 ;
+9 ;----------
CMGRACT(BICMGR) ;EP
+1 ;---> Return 1 if the Case Manager is INACTIVE.
+2 ;---> Parameters:
+3 ; 1 - BICMGR (req) IEN of Case Manager.
+4 ;
+5 IF '$GET(BICMGR)
QUIT 1
+6 IF '$DATA(^BIMGR(BICMGR,0))
QUIT 1
+7 QUIT $PIECE(^BIMGR(BICMGR,0),U,2)
+8 ;
+9 ;
+10 ;----------
CMGRDEF(DUZ2,X) ;EP
+1 ;---> Return Default Case Manager for this site.
+2 ;---> Parameters:
+3 ; 1 - DUZ2 (req) User's DUZ(2)
+4 ; 2 - X (opt) X=1 to return TEXT of default Case Manager name.
+5 ;
+6 IF '$GET(DUZ2)
QUIT ""
+7 NEW Y
SET Y=$PIECE($GET(^BISITE(DUZ2,0)),U,2)
+8 IF 'Y
QUIT ""
+9 IF '$DATA(^BIMGR(Y,0))
QUIT ""
+10 IF '$GET(X)
QUIT Y
+11 IF $$CMGRACT(Y)
QUIT $EXTRACT($$PERSON^BIUTL1(Y),1,20)_" * INACTIVE!"
+12 QUIT $$PERSON^BIUTL1(Y)
+13 ;
+14 ;
+15 ;----------
DEFLET(DUZ2,X,Z) ;EP
+1 ;---> Return Default Letters (Standard Due Letter,
+2 ;---> Official Imm Record).
+3 ;---> Parameters:
+4 ; 1 - DUZ2 (req) User's DUZ(2)
+5 ; 2 - X (opt) X=1 to return TEXT of default Due Letter.
+6 ; 3 - Z (opt) Z="" returns Standard Due Letter.
+7 ; Z=1 returns Official Immunization Record.
+8 ;
+9 IF '$GET(DUZ2)
QUIT ""
+10 NEW Y
SET Y=$PIECE($GET(^BISITE(DUZ2,0)),U,$SELECT($GET(Z):13,1:4))
+11 IF '$GET(X)
QUIT Y
+12 IF 'Y
QUIT ""
+13 QUIT $PIECE($GET(^BILET(Y,0)),U)
+14 ;
+15 ;
+16 ;----------
MINDAYS(DUZ2) ;EP
+1 ;---> Return Default Minimum Days Since Last Letter sent
+2 ;---> for this site.
+3 ;---> Parameters:
+4 ; 1 - DUZ2 (req) User's DUZ(2)
+5 ;
+6 IF '$GET(DUZ2)
QUIT 60
+7 NEW Y
SET Y=$PIECE($GET(^BISITE(DUZ2,0)),U,5)
+8 IF Y=""
QUIT 60
+9 QUIT Y
+10 ;
+11 ;
+12 ;----------
MINAGE(DUZ2) ;EP
+1 ;---> Return parameter to forecast immunizations due at either the
+2 ;---> Minimum Acceptable Age or at the Recommended Age for this site.
+3 ;---> Parameters:
+4 ; 1 - DUZ2 (req) User's DUZ(2)
+5 ;
+6 ;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
+7 ;---> Change returned value to 1 or 0 to accommodate new forecaster.
+8 IF '$GET(DUZ2)
QUIT 0
+9 IF ($PIECE($GET(^BISITE(DUZ2,0)),U,7)="A")
QUIT 1
+10 QUIT 0
+11 ;**********
+12 ;
+13 ;
+14 ;----------
RULES(DUZ2) ;EP
+1 ;---> Return parameter indicating which set of Immserve Forecasting
+2 ;---> Rules is being used (passed to Immserve).
+3 ;---> Parameters:
+4 ; 1 - DUZ2 (req) User's DUZ(2)
+5 ;
+6 NEW Y
SET Y=$$VALIDRUL(DUZ2)
+7 IF 'Y
QUIT "IHS_1m18"
+8 QUIT "IHS_"_Y
+9 ;
+10 ;
+11 ;----------
VALIDRUL(DUZ2) ;EP
+1 ;---> Return whether current Immserve Site Parameter is a valid choice.
+2 ;---> Return 0 is NOT a valid choice; otherwise return the numeric choice.
+3 ;---> Parameters:
+4 ; 1 - DUZ2 (req) User's DUZ(2)
+5 ;
+6 IF '$GET(DUZ2)
QUIT 0
+7 NEW X,Y
+8 SET Y=$GET(^BISITE(DUZ(2),0))
SET X=$PIECE(Y,U,8)
+9 ;---> For a new set of Immserve Rules, change here below and $$RULES+10^BISITE2.
+10 ;---> Current valid choices are 1,2,3,4,5,11.
+11 IF ((X<1)!(X>11))
QUIT 0
+12 IF ((X>7)&(X<11))
QUIT 0
+13 QUIT X_$SELECT($PIECE(Y,U,21):"g",1:"")_$SELECT($PIECE(Y,U,24)=2:"m26",1:"m18")
+14 ;
+15 ;
+16 ;----------
VISDEF(IEN) ;EP
+1 ;---> Return the Default Date of the Vaccine Information Statement
+2 ;---> (VIS) for this vaccine (Fileman format).
+3 ;---> Parameters:
+4 ; 1 - IEN (req) IEN of Vaccine in IMMUNIZATION File (9999999.14).
+5 ;
+6 IF '$GET(IEN)
QUIT ""
+7 IF '$DATA(^AUTTIMM(IEN,0))
QUIT ""
+8 QUIT $PIECE(^AUTTIMM(IEN,0),"^",13)
+9 ;
+10 ;
+11 ;----------
ZIS(BIPOP,BIQUE,BIDEF,BIPRMPT,BIMES) ;EP
+1 ;---> Call to ^%ZIS
+2 ;---> Parameters:
+3 ; 1 - BIPOP (ret) BIPOP=1 if POP=1 (fail or quit).
+4 ; 2 - BIQUE=1 (opt) SET=1 if job should be queueable.
+5 ; 3 - BIDEF=DEFAULT (opt) If exists, equals Default DEVICE.
+6 ; 4 - BIPRMPT (opt) If exists, equals PROMPT.
+7 ; 5 - BIMES (opt) A message to display if QUEUED.
+8 ;
+9 ;---> Example: D ZIS^BIUTL2(.BIPOP,1,"HOME")
+10 ;
ZIS1 ;EP for loop back from failed BIQUE.
+1 SET BIPOP=0
+2 ;
+3 ;---> BIPRMPT=BIPRMPT.
+4 SET %ZIS("A")=$SELECT($DATA(BIPRMPT):BIPRMPT,1:" Select DEVICE: ")
+5 ;
+6 ;---> BIDEF=DEFAULT PRINTER.
+7 ;---> IF NO BIDEF, SET BIDEF="P" FOR CLOSEST PRINTER.
+8 Begin DoDot:1
+9 IF '$DATA(BIDEF)
SET %ZIS="P"
QUIT
+10 SET %ZIS("B")=BIDEF
SET %ZIS=""
End DoDot:1
+11 ;
+12 ;---> If BIQUE=1,job may be queued.
+13 IF $GET(BIQUE)]""
IF BIQUE
SET %ZIS=%ZIS_"Q"
+14 ;
+15 WRITE !
DO ^%ZIS
IF POP
SET BIPOP=1
+16 ;---> Quit if BIPOP (DUOUT or DTOUT) or if not queued.
+17 IF BIPOP!('$DATA(IO("Q")))
GOTO ZISEXIT
+18 ;
+19 IF IO=IO(0)
WRITE !?5,"Cannot queue to screen or slave printer!",!
GOTO ZIS1
+20 ;
+21 ;---> NEXT LINE: Line Label "ZISQ" added for entry where Device
+22 ;---> Info has already been adked and User queued output.
ZISQ ;EP
+1 ;---> NEXT LINES: Job was queued, therefore set BIPOP=1 so that the
+2 ;---> calling routine will quit (and let Taskman finish this job).
+3 SET BIPOP=1
+4 IF '$DATA(ZTRTN)
Begin DoDot:1
+5 WRITE !?5,*7,"NO ROUTINE NAMED FOR QUEUEING -- CONTACT PROGRAMMER."
End DoDot:1
GOTO ZISEXIT
+6 IF '$DATA(ZTDESC)
SET ZTDESC=ZTRTN
+7 SET BIMES=$SELECT($DATA(BIMES):BIMES,1:"W !?5,""Request Queued."",!")
+8 ;
+9 SET ZTIO=$SELECT($DATA(ION):ION,1:"")
+10 IF ZTIO]""
Begin DoDot:1
+11 IF $DATA(IO("DOC"))
SET ZTIO=ZTIO_";"_IOST_";"_IO("DOC")
QUIT
+12 SET ZTIO=ZTIO_";"_IOST_";"_IOM_";"_IOSL
End DoDot:1
+13 ;
+14 ;---> Uncomment next line to suppress "Requested Start Time" question.
+15 ;S ZTDTH=$H
+16 DO ^%ZTLOAD
DO ^%ZISC
+17 IF $DATA(ZTQUEUED)
XECUTE BIMES
HANG 2
+18 ;
ZISEXIT ;EP
+1 KILL BIMES,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+2 QUIT
+3 ;
+4 ;
+5 ;----------
DFNCHECK() ;EP
+1 ;---> If BIDFN not supplied, set Error Code and quit.
+2 IF '$GET(BIDFN)
DO ERRCD^BIUTL2(201,,1)
QUIT 1
+3 QUIT 0
+4 ;
+5 ;
+6 ;----------
DUZCHECK() ;EP
+1 ;---> If no BIDUZ2 (Site IEN), Set it equal to User's DUZ(2).
+2 ;---> If User's DUZ(2) fails, set Error Code and quit.
+3 IF '$GET(BIDUZ2)
SET BIDUZ2=$GET(DUZ(2))
+4 IF '$GET(BIDUZ2)
DO ERRCD^BIUTL2(105,,1)
QUIT 1
+5 QUIT 0
+6 ;
+7 ;
VMAX(IEN) ;EP ;MWRZZZ REMOVE?
+1 ;---> Return the Maximum Dose# for a Vaccine.
+2 ;---> Parameters:
+3 ; 1 - IEN (req) IEN of Vaccine.
+4 ;
+5 QUIT ""
+6 QUIT $PIECE(^AUTTIMM(IEN,0),"^",5)
