BIUTL8 ;IHS/CMI/MWR - UTIL: PATLKUP, PRTLST, ZGBL; MAY 10, 2010
;;8.5;IMMUNIZATION;**13**;AUG 01,2016
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; UTILITY: PATIENT LOOKUP, DUPTEST, PRINT LIST, K/ZGBL, KILLALL.
;; HFSPATH, IMMSVDIR.
;; PATCH 2: Correct 19yrs and older logic. VFCSET+7
;; PATCH 3: Display Elig Code Local Text. ELIGLAB+0
;; PATCH 8: Problem Dose changes to accommodate new forecaster. PDSS+11
;; PATCH 9: Fix so that TAB key will not skip Eligibility. ELIGLAB+10
;; Return the IP Address used for the TCH Forecaster. IPTCH
;; Add default of V01 (Ineligible) for patients 19 and over. VFCSET+14
;; PATCH 10: Screen code for PPD Lot Number in Lot Number File. LOTSCRS+0
;; PATCH 13: Return Flu Season Start and End Dates. FLUDATS+0
;
;----------
PATLKUP(BIDFN,BIADD,DUZ2,BIPOP) ;EP
;---> BI Patient Lookup.
;---> Parameters:
; 1 - BIDFN (ret) Patient DFN or -1 if failed.
; 2 - BIADD (opt) ="ADD" If ADD capability during lookup.
; 3 - DUZ2=DUZ(2) (opt) If not set, will=User's DUZ(2).
; 4 - BIPOP (ret) BIPOP=1 If DTOUT or DUOUT.
;
;---> Example: D PATLKUP^BIUTL8(.BIDFN)
; D PATLKUP^BIUTL8(.BIDFN,"ADD") - May ADD Patient to IMM
;
N DFN,DIC,X,Y
S (BIDFN,BIPOP)=0 D SETVARS^BIUTL5
S:$G(DUZ2)]"" DUZ(2)=DUZ2
S DIC="^AUPNPAT(",DIC(0)="AEMQ"
S DIC("A")=" Select Patient Name or Chart#: "
D ^DIC
I $D(DUOUT)!($D(DTOUT)) S BIPOP=1 Q
S BIDFN=+Y
;---> Lookup unsuccessful or aborted.
Q:Y<0
;
;---> If Patient does not exist in BI PATIENT File, add.
I '$D(^BIP(BIDFN,0)) D Q
.;
.;---> If patient is deceased, add as Inactive, Deceased, and quit.
.I $$DECEASED^BIUTL1(BIDFN) D ADDPAT^BIPATE(BIDFN,DUZ(2),,$G(DT),"d") Q
.N BIERR
.;
.;---> If patient is over 18, or if user does not have BIZ EDIT PATIENTS Key,
.;---> then add as Inactive, "Never Activated," and quit.
.I ($$AGE^BIUTL1(BIDFN,1)>18)!($G(BIADD)'="ADD") D Q
..D ADDPAT^BIPATE(BIDFN,DUZ(2),.BIERR,$G(DT),"n")
..I $G(BIERR)]"" W !!?3,BIERR D DIRZ^BIUTL3() S BIPOP=1
.;
.;---> User may edit.
.W !!?3,$$NAME^BIUTL1(BIDFN)
.W " is being added to the Immunization Database",!,"for the first time."
.W !!?3,"Should this patient be added as Active or Inactive?"
.N DIR
.S DIR("?")=" Enter A for Active or I for Inactive."
.S DIR(0)="SM^A:Active;I:Inactive"
.S DIR("A")=" Enter A (Active) or I (Inactive)"
.S DIR("B")="A"
.;S DIR("B")=$S($$AGE^BIUTL1(BIDFN,1)<19:"A",1:"I")
.D ^DIR W !
.I $D(DIRUT) S BIPOP=1 Q
.N BINACT S BINACT=$S(Y="I":$G(DT),1:"")
.N BINACTR S BINACTR=$S(BINACT:"n",1:"")
.D ADDPAT^BIPATE(BIDFN,DUZ(2),.BIERR,BINACT,BINACTR)
.I $G(BIERR)]"" W !!?3,BIERR D DIRZ^BIUTL3() S BIPOP=1
;
;
;---> If this Patient is already in the Imm Database and <36 months
;---> but is Inactive, query.
Q:$$AGE^BIUTL1(BIDFN,2,$G(DT))>35
;Q:'$$INACT^BIUTL1(BIDFN) ;vvv83
Q:($$INACT^BIUTL1(BIDFN)="")
Q:($G(BIADD)'="ADD")
;
W !!?3,"This patient is less than 36 months old and ",$$SEX^BIUTL1(BIDFN,3)
W !?3,"Immunization Status is INACTIVE."
W !!?3,"Should this patient's Status be changed to ACTIVE?",!
N DIR
S DIR(0)="YA",DIR("A")=" Enter Yes or No: "
S DIR("?",1)=" Enter YES to change this patient's Status to Active."
S DIR("?")=" Enter No to leave it Inactive."
D ^DIR W !
D:Y=1
.N BIFLD,BIERR S BIFLD(.08)="",BIFLD(.16)=""
.D FDIE^BIFMAN(9002084,BIDFN,.BIFLD,.BIERR,1)
.I $G(BIERR)]"" W !!?3,BIERR D DIRZ^BIUTL3() S BIPOP=1
Q
;
;
;----------
VFCSET ;EP
;---> Load Vaccine Eligibility. Called by LOADVIS^BIUTL7.
;---> If Patient Ben Type is 01 (Am Indian/AK Native), set VFC default=4.
;
Q:$G(BI("P"))]""
Q:'$G(BIDFN)
Q:$$BENTYP^BIUTL11(BIDFN,2)'="01"
;
;********** PATCH 2, v8.5, MAY 15,2012, IHS/CMI/MWR
;--->Correct 19yrs and older logic.
N BIDATE,X,Y S X=$P($G(BI("E"))," ")
D ^%DT S BIDATE=Y
Q:'BIDATE
;
;********** PATCH 9, v8.5, OCT 01,2014, IHS/CMI/MWR
;---> Add default of V01 (Ineligible) for patients 19 and over.
;
;--> If patient was less than 19yrs set default=V01 and quit.
;Q:($$AGE^BIUTL1(BIDFN,1,BIDATE)>18)
I ($$AGE^BIUTL1(BIDFN,1,BIDATE)<19) S BI("P")=4 Q
;---> Otherwise patient is adult, set default="V01".
S BI("P")=1
;
;********** 9/2012: CHANGE HERE TO MAKE DEFAULT CONDITIONAL UPON ACTIVE STATUS.
Q
;
;
;********** PATCH 3, v8.5, SEP 10,2012, IHS/CMI/MWR
;---> Display Elig Code Label Text.
;----------
ELIGLAB(X) ;EP
;---> Called by Post Action field of Field 10.5 on BI FORM-IMM VISIT ADD/EDIT.
;---> Display Elibigility Code Local Text besind Elig Code.
;---> Parameters:
; 1 - X (req) IEN of Elig Code in ^BIELIG.
;
Q:'$G(X)
N Y S Y=$G(^BIELIG(+X,0))
Q:(Y="")
;
;********** PATCH 9, v8.5, OCT 01,2014, IHS/CMI/MWR
;---> Fix so that TAB key will not skip Eligibility.
;D PUT^DDSVALF(10.6,,,$P(Y,U)_" - "_$P(Y,U,4))
D PUT^DDSVALF(10.6,,," - "_$P(Y,U,4))
Q
;**********
;
;----------
DUPTEST(BIERR,BIDATA,BIOIEN) ;EP
;---> Test to be sure a duplicate Immunization or Skin Test
;---> is not being added.
;---> Parameters:
; 1 - BIERR (ret) Text of Error Code if any, otherwise null.
; 2 - BIDATA (req) String of data for the Visit to be added.
; 3 - BIOIEN (opt) IEN of V IMM or V SKIN being edited (if
; not new).
;
;---> Pieces of BIDATA:
; -----------------
; 1 - A (req) "I"=Immunization Visit, "S"=Skin Text Visit.
; 2 - B (req) DFN of patient.
; 3 - C (req) Vaccine or Skin Test .01 pointer.
; 6 - D (req) Date of Visit.
;
N A,B,BI31,C,D,V,X S BI31=$C(31)_$C(31),V="|",X=""
S A=$P(BIDATA,V,1)
S B=$P(BIDATA,V,2) Q:'B
S C=$P(BIDATA,V,3) Q:'C
S D=9999999-$P($P(BIDATA,V,6),".") Q:'D
;
;---> Check for duplicate visit.
D
.;---> If this is a new Immunization or Skin Test,
.;---> and there exists a duplicate, report the error.
.I '$G(BIOIEN),A="I",$D(^AUPNVIMM("AA",B,C,D)) S X=423 Q
.I '$G(BIOIEN),A="S",$D(^AUPNVSK("AA",B,C,D)) S X=424 Q
.;
.;---> If the existing xref is not that of the edited visit,
.;---> and there exists a duplicate, report the error.
.;---> For an Immunization.
.I A="I" D Q
..N N S N=0
..F S N=$O(^AUPNVIMM("AA",B,C,D,N)) Q:'N I N,N'=BIOIEN S X=423
.;
.;---> For a Skin Test.
.I A="S" D Q
..N N S N=0
..F S N=$O(^AUPNVSK("AA",B,C,D,N)) Q:'N I N,N'=BIOIEN S X=424
;
I X D ERRCD^BIUTL2(X,.BIERR) S BIERR=BI31_BIERR
Q
;
;
;----------
PRTLST(BITNOD) ;EP
;---> Print Listman list instead of displaying it.
;---> Parameters:
; 1 - BITNOD (req) Node in ^TMP global where list is stored.
;
;---> Variables:
; 1 - VALMHDR (req) Array containing header code.
;
N BICRT S BICRT=$S(($E(IOST)="C")!(IOST["BROWSER"):1,1:0)
N BIPAGE,BIPOP S BIPAGE=0,BIPOP=0
N BI31 S BI31=$C(31)_$C(31)
U IO
;---> To eliminate control chars from printouts.
I BICRT D FULL^VALM1 W @IOF
D PHEADER(.BIPAGE)
;
;---> Loop through ^TMP, writing lines of report.
N N S N=0
F S N=$O(^TMP(BITNOD,$J,N)) Q:'N D Q:BIPOP
.N BITEXT S BITEXT=^TMP(BITNOD,$J,N,0)
.;---> Set BIN=number of lines in this record (=number of $C(30)'s).
.N BIN S BIN=$P(BITEXT,BI31,2)
.S BIN=$L(BIN,$C(30))-1
.;
.;---> If this is not the very first line, and if this record
.;---> won't fit on the bottom of this page, do formfeed and header.
.I N>1 I $Y+BIN+3>IOSL D Q:BIPOP W @IOF D PHEADER(.BIPAGE)
..D:BICRT DIRZ^BIUTL3(.BIPOP)
.;
.W !,$P(BITEXT,BI31)
;
W:'BICRT @IOF D:(BICRT&('BIPOP)) DIRZ^BIUTL3()
D ^%ZISC
Q
;
;
;----------
;---> Print header for PRTLST above.
;---> Parameters:
; 1 - BIPAGE (req) Last page# printed.
;
S:'$G(BIPAGE) BIPAGE=0 S BIPAGE=BIPAGE+1
N N S N=0
F S N=$O(VALMHDR(N)) Q:'N D
.;---> If this is line 2 of the header, append page#.
.I N=2 S $E(VALMHDR(2),70,79)=" page "_BIPAGE
.W !,VALMHDR(N)
W !,$$SP^BIUTL5(79,"=")
Q
;
;
;----------
KGBL(BIGBL) ;EP
;---> Kill a global. Global should include leading "^".
;---> Parameters:
; 1 - BIGBL (req) Global to be zeroed out (must include "^").
;
S:BIGBL["(" BIGBL=$P(BIGBL,"(")
F S BIGBL=$Q(@BIGBL) Q:BIGBL="" K @BIGBL
Q
;
;
;----------
ZGBL(BIGBL) ;EP
;---> Zero out (delete ALL DATA) in a Fileman file.
;---> Parameters:
; 1 - BIGBL (req) Global to be zeroed out.
;
Q:$G(BIGBL)=""
N N,X S U="^"
S:$E(BIGBL)'=U BIGBL=U_BIGBL
S:BIGBL["(" BIGBL=$P(BIGBL,"(")
Q:'$D(@(BIGBL_"(0)"))
S N=-1,X=$P(@(BIGBL_"(0)"),U,1,2)
F S N=$O(@(BIGBL_"("""_N_""")")) Q:N="" K @(BIGBL_"("""_N_""")")
S @(BIGBL_"(0)")=X
Q
;
;
;----------
KILLALL(BIGLOBS) ;EP
;---> Clean up local variables.
;---> Parameters:
; 1 - BIGLOBS (opt) If BIGLOBS=1 kill temp globals too.
;
;---> XB call to kill local variables.
D EN^XBVK("BI")
D EN^XBVK("DI")
;
;---> FILEMAN KILLS.
D DKILLS^BIFMAN
D CLEAN^DILF
K I,M,N,X,Y,Z,ZTRTN,ZTSAVE
;
Q:'$G(BIGLOBS)
;---> Clean up temp globals.
K ^BITMP($J)
;
Q
;
;---> Other ways:
;---> MSM
;S X="BI" F S X=$O(@X) Q:$E(X,1,2)'="BI" K @X
;S X="DI" F S X=$O(@X) Q:$E(X,1,2)'="BI" K @X
;---> DSM
;S X="BI" F S X=$ZSORT(@X) Q:$E(X,1,2)'="BI" K @X
;S X="DI" F S X=$ZSORT(@X) Q:$E(X,1,2)'="BI" K @X
Q
;
;
;----------
HFSPATH(DUZ2) ;EP
;---> Return the Host File Path (directory) as set in the
;---> in the BI SITE PARAMETERS File.
;---> Parameters:
; 1 - DUZ2 (opt) User's DUZ(2), otherwise IEN of Site in
; RPMS SITE PARAMETERS File.
;
S:'$G(DUZ2) DUZ2=$P($G(^AUTTSITE(1,0)),"^")
Q $P($G(^BISITE(+DUZ2,0)),"^",14)
;
;
;********** PATCH 9, v8.5, OCT 01,2014, IHS/CMI/MWR
;---> IP Address for TCH Forecaster.
;----------
IPTCH(DUZ2) ;EP
;---> Return the IP Address used for the TCH Forecaster
;---> in the BI SITE PARAMETERS File.
;---> Parameters:
; 1 - DUZ2 (opt) User's DUZ(2), otherwise IEN of Site in
; RPMS SITE PARAMETERS File.
;
S:'$G(DUZ2) DUZ2=$P($G(^AUTTSITE(1,0)),"^")
N BIIP S BIIP=$P($G(^BISITE(+DUZ2,0)),"^",30)
S:'BIIP BIIP="127.0.0.1"
Q BIIP
;**********
;
;----------
IMMSVDIR(DUZ2) ;EP
;---> Return the MSM Home Directory as set in the
;---> in the BI SITE PARAMETERS File.
;---> Parameters:
; 1 - DUZ2 (opt) User's DUZ(2), otherwise IEN of Site in
; RPMS SITE PARAMETERS File.
;
S:'$G(DUZ2) DUZ2=$P($G(^AUTTSITE(1,0)),"^")
Q $P($G(^BISITE(+DUZ2,0)),"^",18)
;
;
;----------
PDSS(BIVIEN,BICOMP,BIPDSS) ;EP
;---> Return 1 if this V Imm IEN is contained in the ImmServe
;---> Problem Dose IEN string; return 0 if not.
;---> Parameters:
; 1 - BIVIEN (req) Visit IEN of this immunization.
; 2 - BICOMP (req) Vaccine Component CVX Code.
; 2 - BIPDSS (req) String of ImmServe Problem Dose IENs.
;
Q:'$G(BIVIEN) 0
Q:'$G(BICOMP) 0
Q:'$D(BIPDSS) 0
;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
;---> Concat leading zero if single digit.
;I $L(BICOMP)=1 S BICOMP="0"_BICOMP
N I,X,Y,Z S X=0
;
;---> Ignore component CVX for now.
S Y=BIVIEN_"%"_BICOMP
F I=1:1 S Z=$P(BIPDSS,U,I) Q:Z="" I Y=Z S X=1 Q
;---> Just check for V Imm IEN.
;F I=1:1 S Z=$P(BIPDSS,U,I) Q:Z="" I BIVIEN=Z S X=1 Q
;**********
;
Q X
;
;
;----------
DOVER(X,Z) ;EP
;---> Return text of Dose Override Code.
;---> Parameters:
; 1 - X (req) Code for Dose Override text.
; 2 - Z (opt) If Z=1 return Short form (remove "INVALID--" from text).
;
Q:'$G(X) ""
Q:$G(Z) $P($P($P($G(^DD(9000010.11,.08,0)),X_":",2),";"),"--",2)
Q $P($P($G(^DD(9000010.11,.08,0)),X_":",2),";")
;
;********** PATCH 10, v8.5, MAY 30,2015, IHS/CMI/MWR
;---> Screen code for PPD Lot Number in Lot Number File.
;----------
LOTSCRS ;EP
;---> Set Screen for Lot Number selection in Screen field of
;---> "Form Only Field Parameters" of the Form BI FORM-SKIN VISIT ADD/EDIT
;---> when selecting Lot Number.
;---> Screen: If this Lot Number is Active, AND if the Skin Test selected is
;---> PPD, AND if EITHER [it has no specific Location] OR its Facility
;---> matches the user's Facility/Location (DUZ(2))].
;
;S DIR("S")="I 0"
S DIR("S")="I $P(^"_"(0),U,3)=0,+$G(BI(""B""))=2,$D(^AUTTIML(""C"",203,Y))"
S DIR("S")=DIR("S")_",(('$P($G(^AUTTIML(Y,0)),U,14))!($P($G(^AUTTIML(Y,0)),U,14)=$G(DUZ(2))))"
Q
;
;---> Next line: Concat to avoid suspected naked ref.
;S DIR("S")="I $P(^"_"(0),U,3)=0,($G(BI(""B""))=""""!$D(^AUTTIML(""C"",+$G(BI(""B"")),Y)))"
;S DIR("S")=DIR("S")_",(('$P($G(^AUTTIML(Y,0)),U,14))!($P($G(^AUTTIML(Y,0)),U,14)=$G(DUZ(2))))"
Q
;**********
;
;
;********** PATCH 13, v8.5, AUG 01,2016, IHS/CMI/MWR
;---> Return Flu Season Start and End Dates.
;----------
FLUDATS(DUZ2) ;PEP - Return Flu Season Start and End Dates.
;---> Return the Flu Season Start and End Dates in the BI SITE PARAMETERS File
;---> in the form: mm/dd%mm/dd
;---> Parameters:
; 1 - DUZ2 (opt) User's DUZ(2), otherwise IEN of Site in
; RPMS SITE PARAMETERS File.
;
S:'$G(DUZ2) DUZ2=$P($G(^AUTTSITE(1,0)),"^")
N X,Y
S X=$P($G(^BISITE(+DUZ2,0)),"^",31),Y=$P($G(^BISITE(+DUZ2,0)),"^",32)
I X'?2N1"/"2N S X="08/01"
I Y'?2N1"/"2N S Y="04/01"
Q X_"%"_Y
;**********
BIUTL8 ;IHS/CMI/MWR - UTIL: PATLKUP, PRTLST, ZGBL; MAY 10, 2010
+1 ;;8.5;IMMUNIZATION;**13**;AUG 01,2016
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; UTILITY: PATIENT LOOKUP, DUPTEST, PRINT LIST, K/ZGBL, KILLALL.
+4 ;; HFSPATH, IMMSVDIR.
+5 ;; PATCH 2: Correct 19yrs and older logic. VFCSET+7
+6 ;; PATCH 3: Display Elig Code Local Text. ELIGLAB+0
+7 ;; PATCH 8: Problem Dose changes to accommodate new forecaster. PDSS+11
+8 ;; PATCH 9: Fix so that TAB key will not skip Eligibility. ELIGLAB+10
+9 ;; Return the IP Address used for the TCH Forecaster. IPTCH
+10 ;; Add default of V01 (Ineligible) for patients 19 and over. VFCSET+14
+11 ;; PATCH 10: Screen code for PPD Lot Number in Lot Number File. LOTSCRS+0
+12 ;; PATCH 13: Return Flu Season Start and End Dates. FLUDATS+0
+13 ;
+14 ;----------
PATLKUP(BIDFN,BIADD,DUZ2,BIPOP) ;EP
+1 ;---> BI Patient Lookup.
+2 ;---> Parameters:
+3 ; 1 - BIDFN (ret) Patient DFN or -1 if failed.
+4 ; 2 - BIADD (opt) ="ADD" If ADD capability during lookup.
+5 ; 3 - DUZ2=DUZ(2) (opt) If not set, will=User's DUZ(2).
+6 ; 4 - BIPOP (ret) BIPOP=1 If DTOUT or DUOUT.
+7 ;
+8 ;---> Example: D PATLKUP^BIUTL8(.BIDFN)
+9 ; D PATLKUP^BIUTL8(.BIDFN,"ADD") - May ADD Patient to IMM
+10 ;
+11 NEW DFN,DIC,X,Y
+12 SET (BIDFN,BIPOP)=0
DO SETVARS^BIUTL5
+13 IF $GET(DUZ2)]""
SET DUZ(2)=DUZ2
+14 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
+15 SET DIC("A")=" Select Patient Name or Chart#: "
+16 DO ^DIC
+17 IF $DATA(DUOUT)!($DATA(DTOUT))
SET BIPOP=1
QUIT
+18 SET BIDFN=+Y
+19 ;---> Lookup unsuccessful or aborted.
+20 IF Y<0
QUIT
+21 ;
+22 ;---> If Patient does not exist in BI PATIENT File, add.
+23 IF '$DATA(^BIP(BIDFN,0))
Begin DoDot:1
+24 ;
+25 ;---> If patient is deceased, add as Inactive, Deceased, and quit.
+26 IF $$DECEASED^BIUTL1(BIDFN)
DO ADDPAT^BIPATE(BIDFN,DUZ(2),,$GET(DT),"d")
QUIT
+27 NEW BIERR
+28 ;
+29 ;---> If patient is over 18, or if user does not have BIZ EDIT PATIENTS Key,
+30 ;---> then add as Inactive, "Never Activated," and quit.
+31 IF ($$AGE^BIUTL1(BIDFN,1)>18)!($GET(BIADD)'="ADD")
Begin DoDot:2
+32 DO ADDPAT^BIPATE(BIDFN,DUZ(2),.BIERR,$GET(DT),"n")
+33 IF $GET(BIERR)]""
WRITE !!?3,BIERR
DO DIRZ^BIUTL3()
SET BIPOP=1
End DoDot:2
QUIT
+34 ;
+35 ;---> User may edit.
+36 WRITE !!?3,$$NAME^BIUTL1(BIDFN)
+37 WRITE " is being added to the Immunization Database",!,"for the first time."
+38 WRITE !!?3,"Should this patient be added as Active or Inactive?"
+39 NEW DIR
+40 SET DIR("?")=" Enter A for Active or I for Inactive."
+41 SET DIR(0)="SM^A:Active;I:Inactive"
+42 SET DIR("A")=" Enter A (Active) or I (Inactive)"
+43 SET DIR("B")="A"
+44 ;S DIR("B")=$S($$AGE^BIUTL1(BIDFN,1)<19:"A",1:"I")
+45 DO ^DIR
WRITE !
+46 IF $DATA(DIRUT)
SET BIPOP=1
QUIT
+47 NEW BINACT
SET BINACT=$SELECT(Y="I":$GET(DT),1:"")
+48 NEW BINACTR
SET BINACTR=$SELECT(BINACT:"n",1:"")
+49 DO ADDPAT^BIPATE(BIDFN,DUZ(2),.BIERR,BINACT,BINACTR)
+50 IF $GET(BIERR)]""
WRITE !!?3,BIERR
DO DIRZ^BIUTL3()
SET BIPOP=1
End DoDot:1
QUIT
+51 ;
+52 ;
+53 ;---> If this Patient is already in the Imm Database and <36 months
+54 ;---> but is Inactive, query.
+55 IF $$AGE^BIUTL1(BIDFN,2,$GET(DT))>35
QUIT
+56 ;Q:'$$INACT^BIUTL1(BIDFN) ;vvv83
+57 IF ($$INACT^BIUTL1(BIDFN)="")
QUIT
+58 IF ($GET(BIADD)'="ADD")
QUIT
+59 ;
+60 WRITE !!?3,"This patient is less than 36 months old and ",$$SEX^BIUTL1(BIDFN,3)
+61 WRITE !?3,"Immunization Status is INACTIVE."
+62 WRITE !!?3,"Should this patient's Status be changed to ACTIVE?",!
+63 NEW DIR
+64 SET DIR(0)="YA"
SET DIR("A")=" Enter Yes or No: "
+65 SET DIR("?",1)=" Enter YES to change this patient's Status to Active."
+66 SET DIR("?")=" Enter No to leave it Inactive."
+67 DO ^DIR
WRITE !
+68 IF Y=1
Begin DoDot:1
+69 NEW BIFLD,BIERR
SET BIFLD(.08)=""
SET BIFLD(.16)=""
+70 DO FDIE^BIFMAN(9002084,BIDFN,.BIFLD,.BIERR,1)
+71 IF $GET(BIERR)]""
WRITE !!?3,BIERR
DO DIRZ^BIUTL3()
SET BIPOP=1
End DoDot:1
+72 QUIT
+73 ;
+74 ;
+75 ;----------
VFCSET ;EP
+1 ;---> Load Vaccine Eligibility. Called by LOADVIS^BIUTL7.
+2 ;---> If Patient Ben Type is 01 (Am Indian/AK Native), set VFC default=4.
+3 ;
+4 IF $GET(BI("P"))]""
QUIT
+5 IF '$GET(BIDFN)
QUIT
+6 IF $$BENTYP^BIUTL11(BIDFN,2)'="01"
QUIT
+7 ;
+8 ;********** PATCH 2, v8.5, MAY 15,2012, IHS/CMI/MWR
+9 ;--->Correct 19yrs and older logic.
+10 NEW BIDATE,X,Y
SET X=$PIECE($GET(BI("E"))," ")
+11 DO ^%DT
SET BIDATE=Y
+12 IF 'BIDATE
QUIT
+13 ;
+14 ;********** PATCH 9, v8.5, OCT 01,2014, IHS/CMI/MWR
+15 ;---> Add default of V01 (Ineligible) for patients 19 and over.
+16 ;
+17 ;--> If patient was less than 19yrs set default=V01 and quit.
+18 ;Q:($$AGE^BIUTL1(BIDFN,1,BIDATE)>18)
+19 IF ($$AGE^BIUTL1(BIDFN,1,BIDATE)<19)
SET BI("P")=4
QUIT
+20 ;---> Otherwise patient is adult, set default="V01".
+21 SET BI("P")=1
+22 ;
+23 ;********** 9/2012: CHANGE HERE TO MAKE DEFAULT CONDITIONAL UPON ACTIVE STATUS.
+24 QUIT
+25 ;
+26 ;
+27 ;********** PATCH 3, v8.5, SEP 10,2012, IHS/CMI/MWR
+28 ;---> Display Elig Code Label Text.
+29 ;----------
ELIGLAB(X) ;EP
+1 ;---> Called by Post Action field of Field 10.5 on BI FORM-IMM VISIT ADD/EDIT.
+2 ;---> Display Elibigility Code Local Text besind Elig Code.
+3 ;---> Parameters:
+4 ; 1 - X (req) IEN of Elig Code in ^BIELIG.
+5 ;
+6 IF '$GET(X)
QUIT
+7 NEW Y
SET Y=$GET(^BIELIG(+X,0))
+8 IF (Y="")
QUIT
+9 ;
+10 ;********** PATCH 9, v8.5, OCT 01,2014, IHS/CMI/MWR
+11 ;---> Fix so that TAB key will not skip Eligibility.
+12 ;D PUT^DDSVALF(10.6,,,$P(Y,U)_" - "_$P(Y,U,4))
+13 DO PUT^DDSVALF(10.6,,," - "_$PIECE(Y,U,4))
+14 QUIT
+15 ;**********
+16 ;
+17 ;----------
DUPTEST(BIERR,BIDATA,BIOIEN) ;EP
+1 ;---> Test to be sure a duplicate Immunization or Skin Test
+2 ;---> is not being added.
+3 ;---> Parameters:
+4 ; 1 - BIERR (ret) Text of Error Code if any, otherwise null.
+5 ; 2 - BIDATA (req) String of data for the Visit to be added.
+6 ; 3 - BIOIEN (opt) IEN of V IMM or V SKIN being edited (if
+7 ; not new).
+8 ;
+9 ;---> Pieces of BIDATA:
+10 ; -----------------
+11 ; 1 - A (req) "I"=Immunization Visit, "S"=Skin Text Visit.
+12 ; 2 - B (req) DFN of patient.
+13 ; 3 - C (req) Vaccine or Skin Test .01 pointer.
+14 ; 6 - D (req) Date of Visit.
+15 ;
+16 NEW A,B,BI31,C,D,V,X
SET BI31=$CHAR(31)_$CHAR(31)
SET V="|"
SET X=""
+17 SET A=$PIECE(BIDATA,V,1)
+18 SET B=$PIECE(BIDATA,V,2)
IF 'B
QUIT
+19 SET C=$PIECE(BIDATA,V,3)
IF 'C
QUIT
+20 SET D=9999999-$PIECE($PIECE(BIDATA,V,6),".")
IF 'D
QUIT
+21 ;
+22 ;---> Check for duplicate visit.
+23 Begin DoDot:1
+24 ;---> If this is a new Immunization or Skin Test,
+25 ;---> and there exists a duplicate, report the error.
+26 IF '$GET(BIOIEN)
IF A="I"
IF $DATA(^AUPNVIMM("AA",B,C,D))
SET X=423
QUIT
+27 IF '$GET(BIOIEN)
IF A="S"
IF $DATA(^AUPNVSK("AA",B,C,D))
SET X=424
QUIT
+28 ;
+29 ;---> If the existing xref is not that of the edited visit,
+30 ;---> and there exists a duplicate, report the error.
+31 ;---> For an Immunization.
+32 IF A="I"
Begin DoDot:2
+33 NEW N
SET N=0
+34 FOR
SET N=$ORDER(^AUPNVIMM("AA",B,C,D,N))
IF 'N
QUIT
IF N
IF N'=BIOIEN
SET X=423
End DoDot:2
QUIT
+35 ;
+36 ;---> For a Skin Test.
+37 IF A="S"
Begin DoDot:2
+38 NEW N
SET N=0
+39 FOR
SET N=$ORDER(^AUPNVSK("AA",B,C,D,N))
IF 'N
QUIT
IF N
IF N'=BIOIEN
SET X=424
End DoDot:2
QUIT
End DoDot:1
+40 ;
+41 IF X
DO ERRCD^BIUTL2(X,.BIERR)
SET BIERR=BI31_BIERR
+42 QUIT
+43 ;
+44 ;
+45 ;----------
PRTLST(BITNOD) ;EP
+1 ;---> Print Listman list instead of displaying it.
+2 ;---> Parameters:
+3 ; 1 - BITNOD (req) Node in ^TMP global where list is stored.
+4 ;
+5 ;---> Variables:
+6 ; 1 - VALMHDR (req) Array containing header code.
+7 ;
+8 NEW BICRT
SET BICRT=$SELECT(($EXTRACT(IOST)="C")!(IOST["BROWSER"):1,1:0)
+9 NEW BIPAGE,BIPOP
SET BIPAGE=0
SET BIPOP=0
+10 NEW BI31
SET BI31=$CHAR(31)_$CHAR(31)
+11 USE IO
+12 ;---> To eliminate control chars from printouts.
+13 IF BICRT
DO FULL^VALM1
WRITE @IOF
+14 DO PHEADER(.BIPAGE)
+15 ;
+16 ;---> Loop through ^TMP, writing lines of report.
+17 NEW N
SET N=0
+18 FOR
SET N=$ORDER(^TMP(BITNOD,$JOB,N))
IF 'N
QUIT
Begin DoDot:1
+19 NEW BITEXT
SET BITEXT=^TMP(BITNOD,$JOB,N,0)
+20 ;---> Set BIN=number of lines in this record (=number of $C(30)'s).
+21 NEW BIN
SET BIN=$PIECE(BITEXT,BI31,2)
+22 SET BIN=$LENGTH(BIN,$CHAR(30))-1
+23 ;
+24 ;---> If this is not the very first line, and if this record
+25 ;---> won't fit on the bottom of this page, do formfeed and header.
+26 IF N>1
IF $Y+BIN+3>IOSL
Begin DoDot:2
+27 IF BICRT
DO DIRZ^BIUTL3(.BIPOP)
End DoDot:2
IF BIPOP
QUIT
WRITE @IOF
DO PHEADER(.BIPAGE)
+28 ;
+29 WRITE !,$PIECE(BITEXT,BI31)
End DoDot:1
IF BIPOP
QUIT
+30 ;
+31 IF 'BICRT
WRITE @IOF
IF (BICRT&('BIPOP))
DO DIRZ^BIUTL3()
+32 DO ^%ZISC
+33 QUIT
+34 ;
+35 ;
+36 ;----------
+1 ;---> Print header for PRTLST above.
+2 ;---> Parameters:
+3 ; 1 - BIPAGE (req) Last page# printed.
+4 ;
+5 IF '$GET(BIPAGE)
SET BIPAGE=0
SET BIPAGE=BIPAGE+1
+6 NEW N
SET N=0
+7 FOR
SET N=$ORDER(VALMHDR(N))
IF 'N
QUIT
Begin DoDot:1
+8 ;---> If this is line 2 of the header, append page#.
+9 IF N=2
SET $EXTRACT(VALMHDR(2),70,79)=" page "_BIPAGE
+10 WRITE !,VALMHDR(N)
End DoDot:1
+11 WRITE !,$$SP^BIUTL5(79,"=")
+12 QUIT
+13 ;
+14 ;
+15 ;----------
KGBL(BIGBL) ;EP
+1 ;---> Kill a global. Global should include leading "^".
+2 ;---> Parameters:
+3 ; 1 - BIGBL (req) Global to be zeroed out (must include "^").
+4 ;
+5 IF BIGBL["("
SET BIGBL=$PIECE(BIGBL,"(")
+6 FOR
SET BIGBL=$QUERY(@BIGBL)
IF BIGBL=""
QUIT
KILL @BIGBL
+7 QUIT
+8 ;
+9 ;
+10 ;----------
ZGBL(BIGBL) ;EP
+1 ;---> Zero out (delete ALL DATA) in a Fileman file.
+2 ;---> Parameters:
+3 ; 1 - BIGBL (req) Global to be zeroed out.
+4 ;
+5 IF $GET(BIGBL)=""
QUIT
+6 NEW N,X
SET U="^"
+7 IF $EXTRACT(BIGBL)'=U
SET BIGBL=U_BIGBL
+8 IF BIGBL["("
SET BIGBL=$PIECE(BIGBL,"(")
+9 IF '$DATA(@(BIGBL_"(0)"))
QUIT
+10 SET N=-1
SET X=$PIECE(@(BIGBL_"(0)"),U,1,2)
+11 FOR
SET N=$ORDER(@(BIGBL_"("""_N_""")"))
IF N=""
QUIT
KILL @(BIGBL_"("""_N_""")")
+12 SET @(BIGBL_"(0)")=X
+13 QUIT
+14 ;
+15 ;
+16 ;----------
KILLALL(BIGLOBS) ;EP
+1 ;---> Clean up local variables.
+2 ;---> Parameters:
+3 ; 1 - BIGLOBS (opt) If BIGLOBS=1 kill temp globals too.
+4 ;
+5 ;---> XB call to kill local variables.
+6 DO EN^XBVK("BI")
+7 DO EN^XBVK("DI")
+8 ;
+9 ;---> FILEMAN KILLS.
+10 DO DKILLS^BIFMAN
+11 DO CLEAN^DILF
+12 KILL I,M,N,X,Y,Z,ZTRTN,ZTSAVE
+13 ;
+14 IF '$GET(BIGLOBS)
QUIT
+15 ;---> Clean up temp globals.
+16 KILL ^BITMP($JOB)
+17 ;
+18 QUIT
+19 ;
+20 ;---> Other ways:
+21 ;---> MSM
+22 ;S X="BI" F S X=$O(@X) Q:$E(X,1,2)'="BI" K @X
+23 ;S X="DI" F S X=$O(@X) Q:$E(X,1,2)'="BI" K @X
+24 ;---> DSM
+25 ;S X="BI" F S X=$ZSORT(@X) Q:$E(X,1,2)'="BI" K @X
+26 ;S X="DI" F S X=$ZSORT(@X) Q:$E(X,1,2)'="BI" K @X
+27 QUIT
+28 ;
+29 ;
+30 ;----------
HFSPATH(DUZ2) ;EP
+1 ;---> Return the Host File Path (directory) as set in the
+2 ;---> in the BI SITE PARAMETERS File.
+3 ;---> Parameters:
+4 ; 1 - DUZ2 (opt) User's DUZ(2), otherwise IEN of Site in
+5 ; RPMS SITE PARAMETERS File.
+6 ;
+7 IF '$GET(DUZ2)
SET DUZ2=$PIECE($GET(^AUTTSITE(1,0)),"^")
+8 QUIT $PIECE($GET(^BISITE(+DUZ2,0)),"^",14)
+9 ;
+10 ;
+11 ;********** PATCH 9, v8.5, OCT 01,2014, IHS/CMI/MWR
+12 ;---> IP Address for TCH Forecaster.
+13 ;----------
IPTCH(DUZ2) ;EP
+1 ;---> Return the IP Address used for the TCH Forecaster
+2 ;---> in the BI SITE PARAMETERS File.
+3 ;---> Parameters:
+4 ; 1 - DUZ2 (opt) User's DUZ(2), otherwise IEN of Site in
+5 ; RPMS SITE PARAMETERS File.
+6 ;
+7 IF '$GET(DUZ2)
SET DUZ2=$PIECE($GET(^AUTTSITE(1,0)),"^")
+8 NEW BIIP
SET BIIP=$PIECE($GET(^BISITE(+DUZ2,0)),"^",30)
+9 IF 'BIIP
SET BIIP="127.0.0.1"
+10 QUIT BIIP
+11 ;**********
+12 ;
+13 ;----------
IMMSVDIR(DUZ2) ;EP
+1 ;---> Return the MSM Home Directory as set in the
+2 ;---> in the BI SITE PARAMETERS File.
+3 ;---> Parameters:
+4 ; 1 - DUZ2 (opt) User's DUZ(2), otherwise IEN of Site in
+5 ; RPMS SITE PARAMETERS File.
+6 ;
+7 IF '$GET(DUZ2)
SET DUZ2=$PIECE($GET(^AUTTSITE(1,0)),"^")
+8 QUIT $PIECE($GET(^BISITE(+DUZ2,0)),"^",18)
+9 ;
+10 ;
+11 ;----------
PDSS(BIVIEN,BICOMP,BIPDSS) ;EP
+1 ;---> Return 1 if this V Imm IEN is contained in the ImmServe
+2 ;---> Problem Dose IEN string; return 0 if not.
+3 ;---> Parameters:
+4 ; 1 - BIVIEN (req) Visit IEN of this immunization.
+5 ; 2 - BICOMP (req) Vaccine Component CVX Code.
+6 ; 2 - BIPDSS (req) String of ImmServe Problem Dose IENs.
+7 ;
+8 IF '$GET(BIVIEN)
QUIT 0
+9 IF '$GET(BICOMP)
QUIT 0
+10 IF '$DATA(BIPDSS)
QUIT 0
+11 ;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
+12 ;---> Concat leading zero if single digit.
+13 ;I $L(BICOMP)=1 S BICOMP="0"_BICOMP
+14 NEW I,X,Y,Z
SET X=0
+15 ;
+16 ;---> Ignore component CVX for now.
+17 SET Y=BIVIEN_"%"_BICOMP
+18 FOR I=1:1
SET Z=$PIECE(BIPDSS,U,I)
IF Z=""
QUIT
IF Y=Z
SET X=1
QUIT
+19 ;---> Just check for V Imm IEN.
+20 ;F I=1:1 S Z=$P(BIPDSS,U,I) Q:Z="" I BIVIEN=Z S X=1 Q
+21 ;**********
+22 ;
+23 QUIT X
+24 ;
+25 ;
+26 ;----------
DOVER(X,Z) ;EP
+1 ;---> Return text of Dose Override Code.
+2 ;---> Parameters:
+3 ; 1 - X (req) Code for Dose Override text.
+4 ; 2 - Z (opt) If Z=1 return Short form (remove "INVALID--" from text).
+5 ;
+6 IF '$GET(X)
QUIT ""
+7 IF $GET(Z)
QUIT $PIECE($PIECE($PIECE($GET(^DD(9000010.11,.08,0)),X_":",2),";"),"--",2)
+8 QUIT $PIECE($PIECE($GET(^DD(9000010.11,.08,0)),X_":",2),";")
+9 ;
+10 ;********** PATCH 10, v8.5, MAY 30,2015, IHS/CMI/MWR
+11 ;---> Screen code for PPD Lot Number in Lot Number File.
+12 ;----------
LOTSCRS ;EP
+1 ;---> Set Screen for Lot Number selection in Screen field of
+2 ;---> "Form Only Field Parameters" of the Form BI FORM-SKIN VISIT ADD/EDIT
+3 ;---> when selecting Lot Number.
+4 ;---> Screen: If this Lot Number is Active, AND if the Skin Test selected is
+5 ;---> PPD, AND if EITHER [it has no specific Location] OR its Facility
+6 ;---> matches the user's Facility/Location (DUZ(2))].
+7 ;
+8 ;S DIR("S")="I 0"
+9 SET DIR("S")="I $P(^"_"(0),U,3)=0,+$G(BI(""B""))=2,$D(^AUTTIML(""C"",203,Y))"
+10 SET DIR("S")=DIR("S")_",(('$P($G(^AUTTIML(Y,0)),U,14))!($P($G(^AUTTIML(Y,0)),U,14)=$G(DUZ(2))))"
+11 QUIT
+12 ;
+13 ;---> Next line: Concat to avoid suspected naked ref.
+14 ;S DIR("S")="I $P(^"_"(0),U,3)=0,($G(BI(""B""))=""""!$D(^AUTTIML(""C"",+$G(BI(""B"")),Y)))"
+15 ;S DIR("S")=DIR("S")_",(('$P($G(^AUTTIML(Y,0)),U,14))!($P($G(^AUTTIML(Y,0)),U,14)=$G(DUZ(2))))"
+16 QUIT
+17 ;**********
+18 ;
+19 ;
+20 ;********** PATCH 13, v8.5, AUG 01,2016, IHS/CMI/MWR
+21 ;---> Return Flu Season Start and End Dates.
+22 ;----------
FLUDATS(DUZ2) ;PEP - Return Flu Season Start and End Dates.
+1 ;---> Return the Flu Season Start and End Dates in the BI SITE PARAMETERS File
+2 ;---> in the form: mm/dd%mm/dd
+3 ;---> Parameters:
+4 ; 1 - DUZ2 (opt) User's DUZ(2), otherwise IEN of Site in
+5 ; RPMS SITE PARAMETERS File.
+6 ;
+7 IF '$GET(DUZ2)
SET DUZ2=$PIECE($GET(^AUTTSITE(1,0)),"^")
+8 NEW X,Y
+9 SET X=$PIECE($GET(^BISITE(+DUZ2,0)),"^",31)
SET Y=$PIECE($GET(^BISITE(+DUZ2,0)),"^",32)
+10 IF X'?2N1"/"2N
SET X="08/01"
+11 IF Y'?2N1"/"2N
SET Y="04/01"
+12 QUIT X_"%"_Y
+13 ;**********
