BIUTL8.m

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

 ;

 ;

 ;----------

PHEADER(BIPAGE) ;EP

 ;---> 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      ;----------

PHEADER(BIPAGE) ;EP

 +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      ;