BIUTL11 ;IHS/CMI/MWR - UTIL: PATIENT INFO; AUG 10,2010
;;8.5;IMMUNIZATION;**9**;OCT 01,2014
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; UTILITY: PATIENT FUNCTIONS: CONTRAS, INPATIENT, HIDOSE.
;; PATCH 1: Correct typo "Q", so that unmatched CVX returns 0 (zero),
;; not "Q". LASTIMM+17
;; PATCH 3: Append date to Hx of Chickenpox Reason. CONTRA+45
;; PATCH 5: Unused call, was never a P.E.P.. CONTR+0
;; PATCH 8: For Hx of Chicken Pox, do NOT contraindicate Zoster (CVX=121). CONTRA+62
;; PATCH 9: Add GOTDOSE call: check if patient received a dose. GOTDOSE+0
;
;
;----------
CONTRA(BIDFN,A,BIREF,BIDATE) ;EP
;---> Return an array of a patient's ImmServe Contraindications.
;---> Called by IMMSERV^BIEXPRT5.
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
; 2 - A (ret) Array with subscripts=HL7 CVX Codes of vaccines
; contraindicated for this patient.
; Each node A(CVX)=IEN of the Reason in ^BICONT(
; 3 - BIREF (opt) If BIREF=1, return only Vaccines contraindicated
; because they were refused, i.e., Refusals.
; If BIREF=2, return only Vaccines contraindicated
; because of Hx of Chicken Pox.
; 4 - BIDATE (opt) If BIDATE=1, append Date of contra to Refusals.
;
Q:'$G(BIDFN)
;---> Quit if there are no contraindications for this patient.
Q:'$D(^BIPC("B",BIDFN))
;
N N,U S N=0,U="^"
F S N=$O(^BIPC("B",BIDFN,N)) Q:'N D
.;---> If bad xref, kill it and quit.
.I '$D(^BIPC(N,0)) K ^BIPC("B",BIDFN,N) Q
.N BIPC,X,Y
.;---> BIPC=zero node of a Patient's Contraindication.
.S BIPC=^BIPC(N,0)
.;
.;---> Set X=Reason pointer (to ^BICONT), Y=Date of Contraindication.
.S X=$P(BIPC,U,3),Y=$P(BIPC,U,4)
.;
.;---> If the call is to return an array of Refusals, do so and quit.
.I $G(BIREF)=1 D Q
..;---> 11 & 16 are IENs of BI TABLE CONTRA REASONS ^BICONT( that are REFUSALS.
..I (X=11)!(X=16) D Q
...;---> Set array node A(CVX)=IEN of Refusal Contra Reason.
...N Z S Z=$P(BIPC,U,2) I Z S Z=$G(^AUTTIMM(Z,0)),Z=$P(Z,U,3)
...I Z S A(Z)=X S:$G(BIDATE) A(Z)=A(Z)_U_Y
.;
.;
.;---> If the call is to return an array of Hx of Chicken Pox, do so and quit.
.I $G(BIREF)=2 D Q
..;---> 12 is the IEN of BI TABLE CONTRA REASONS that is Hx of Chicken Pox.
..I X=12 D Q
...;---> Set array node A(CVX)=IEN of Hx of Chicken Pox Reason.
...;
...;********** PATCH 3, v8.5, SEP 10,2012, IHS/CMI/MWR
...;---> Append date to Hx of Chickenpox Reason.
...N Z S Z=$P(BIPC,U,2) I Z S Z=$G(^AUTTIMM(Z,0)),Z=$P(Z,U,3)
...I Z S A(Z)=X S:$G(BIDATE) A(Z)=A(Z)_U_Y
...;**********
.;
.;---> Continue in order to return an array of contra'd vaccines by CVX Code.
.;
.;---> Quit if the Reason for this contraindication is one that
.;---> still allows forecasting of the vaccine. For example,
.;---> if the reason is "Patient Refusal", then the vaccine should
.;---> still be forecast as due.
.I X Q:$P($G(^BICONT(X,0)),U,2)
.;
.;---> For this Vaccine IEN contraindication, get Related Contraindcated CVX Codes.
.;---> (Call below also sets A(CVX) of THIS Vaccine IEN in the A(CVX) array.)
.D CONTRHL7($P(BIPC,U,2),.A)
.;
.;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
.;---> If the vaccine is Varicella (CVX=21) and Reason is Hx of Chicken Pox,
.;---> do NOT contraindicate Zoster (CVX=121).
.I $P(BIPC,U,2)=132,$P(BIPC,U,3)=12 K A(121)
.;**********
;
Q
;
;
;----------
CONTRHL7(BIVAC,A) ;EP
;---> Return an array of Related Contraindcated HL7 Codes for
;---> this vaccine.
;---> Parameters:
; 1 - BIVAC (req) IEN of Vaccine.
; 2 - A (ret) Array with subscripts=HL7 Codes of vaccines
; contraindicated that relate to this vaccine.
;
Q:'$G(BIVAC) Q:'$D(^AUTTIMM(BIVAC,0))
;
;---> Set X=data for this vaccine.
N X S X=^AUTTIMM(BIVAC,0)
;
;---> Set HL7 Code for this contraindicated vaccine in A() array
;---> as a subscript.
Q:'$P(X,U,3)
S A($P(X,U,3))=""
;
;---> Set X=string of Related Contraindicated HL7 Codes for this
;---> vaccine.
S X=$P(X,U,12)
;
;---> Now piece out Contraindicated HL7 Codes (comma delimited)
;---> and set in A() array as subscripts.
N I,Y F I=1:1 S Y=$P(X,",",I) Q:'Y S A(Y)=""
Q
;
;
;----------
CONTR(BIDFN,BIVAC) ;EP
;
;********** PATCH 5, v8.5, JUL 01,2013, IHS/CMI/MWR
;---> REMOVED. Was never a P.E.P.
Q
;
;
;----------
INPT(BIDFN,BIDATE) ;EP
;---> Return 1 if patient was an inpatient on BIDATE.
;---> Called by +84^BIVISIT to correct Category.
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
; 2 - BIDATE (req) Date to check if patient was inpatient.
;
Q:'$G(BIDFN) 0 Q:'$G(BIDATE) 0
;
;---> Get last discharge previous to BIDATE.
N X,Y S BIDATE=9999999.9999999-BIDATE
S X=$O(^AUPNVINP("AA",BIDFN,BIDATE))
;
;---> Now check to see if patient has been admitted since
;---> that discharge date.
S X=$O(^AUPNVSIT("AAH",BIDFN,X),-1)
;
;---> If patient not admitted since last discharge, quit 0.
Q:'X 0
;
;---> If Visit is for Contract Care, quit 0 (not an inpatient).
;---> Next line v8.1 fix: Use X (inv date) to get Y (IEN).
S Y=+$O(^AUPNVSIT("AAH",BIDFN,X,0))
Q:$P($G(^AUPNVSIT(Y,0)),U,3)="C" 0
;
;---> If last admission was after BIDATE (inverse), quit 0.
Q:X<BIDATE 0
;
;---> Patient was an inpatient on BIDATE, quit 1.
Q 1
;
;
;----------
INFL(BIDFN,TEXT) ;EP
;---> Return value of Patient's Forecast Influ/Pneumo field.
;---> 0=Normal, 1=Influenza, 2=Pneumococcal, 3=Both, 4=Disregard Risk Factors.
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN (BIDFN).
; 2 - TEXT (opt) If TEXT=1, return text of the field.
;
Q:'$G(BIDFN) 0
Q:'$D(^BIP(BIDFN,0)) 0
N X S X=+$P(^BIP(BIDFN,0),U,15)
Q:'$G(TEXT) X
Q:X=4 "Disregard Risk Factors"
Q:X=3 "Influenza and Pneumo"
Q:X=2 "Pneumococcal"
Q:X=1 "Influenza"
Q "Normal"
;
;
;----------
MOTHER(BIDFN,BITEXT) ;EP
;---> Return mother's HBsAg Status Code.
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN (BIDFN).
; 2 - BITEXT (opt) If BITEXT=1 return full text.
N X
D
.I '$G(BIDFN) S X="U" Q
.I '$D(^BIP(BIDFN,0)) S X="U" Q
.S X=$P(^BIP(BIDFN,0),U,11)
S:X="" X="U"
Q:'$G(BITEXT) X
Q $S(X="P":"POSITIVE",X="N":"NEGATIVE",1:"UNKNOWN")
;
;
;----------
BENTYP(BIDFN,TEXT) ;EP
;---> Return IEN of Patient's Beneficiary Type.
;---> This is the CLASSIFICATION/BENEFICIARY Code (Item 2 on page 2
;---> of Registration).
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN (DFN).
;---> Text parameter added.
; 2 - TEXT (opt) If TEXT=1, return text of Beneficiary Type.
; If text=2, return Code of Beneficiary Type. vvv83
;
N Y
Q:'$G(BIDFN) 0
S Y=+$P($G(^AUPNPAT(BIDFN,11)),U,11)
Q:'$G(TEXT) Y
Q:$G(TEXT)=2 $P($G(^AUTTBEN(Y,0)),U,2) ;vvv83
Q $P($G(^AUTTBEN(Y,0)),U)
;
;
;----------
OTHERIN(BIDFN) ;EP
;---> Return Patient's Other Info.
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN (BIDFN).
;
Q:'$G(BIDFN) ""
Q $P($G(^BIP(BIDFN,0)),U,13)
;
;
;----------
MAYEDIT() ;EP
;---> Return 1 if User has Immunization Edit Patients Key; 0 if not.
Q:'$D(DUZ) 0
Q:$D(^XUSEC("BIZ EDIT PATIENTS",DUZ)) 1
Q:$D(^XUSEC("BIZ MANAGER",DUZ)) 1
Q 0
;
;
;----------
MAYMANAG() ;EP
;---> Return 1 if User has Immunization Manager Key; 0 if not.
Q:'$D(DUZ) 0
Q:$D(^XUSEC("BIZ MANAGER",DUZ)) 1
Q 0
;
;
;----------
CURCOM(BIDFN,TEXT) ;EP
;---> Return patient's Current Community IEN or Text.
;---> (Item 6 on page 1 of Registration).
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN (BIDFN).
; 2 - TEXT (opt) If TEXT=1, return text of Current Community.
;
Q:'$G(BIDFN) "No Patient"
Q:'$D(^AUPNPAT(BIDFN,11)) "Unknown1"
;
N X,Y,Z
S X=^AUPNPAT(BIDFN,11)
;---> Set Y=Pointer (IEN in ^AUTTCOM, piece 17), Z=Text (piece 18).
S Y=$P(X,U,17),Z=$P(X,U,18)
;---> If both Pointer and Text are null, return "Unknown2".
Q:('Y&(Z="")) "Unknown2"
;
;---> If Y is null or a bad pointer, set Y="".
I Y<1!('$D(^AUTTCOM(+Y,0))) S Y=""
;
;---> If no valid pointer and if Text (pc 18) exists in the
;---> Community file, then set Y=IEN in ^AUTTCOM(, and fix it.
I Y<1,$D(^AUTTCOM("B",Z)) S Y=$O(^AUTTCOM("B",Z,0)) D
.N BIFLD S BIFLD(1117)=Y D FDIE^BIFMAN(9000001,BIDFN,.BIFLD)
;
Q:'$D(^AUTTCOM(+Y,0)) "Unknown3"
;
N BITEXT S BITEXT=$P(^AUTTCOM(Y,0),U)
;---> If text field is off, fix it.
I Z'=BITEXT D
.N BIFLD S BIFLD(1118)=BITEXT D FDIE^BIFMAN(9000001,BIDFN,.BIFLD)
Q:'$G(TEXT) Y
Q $P(^AUTTCOM(Y,0),U)
;
;
;----------
ISGPRA(BIDFN,BISITE,BINOCOM,BIERR) ;PEP - Return 1 if Pt's Current Community is in Imm GPRA Set.
;---> Return 1 if Patient's Current Community is in the Immunization GPRA Set
;---> of Communities as defined in the BI Site Parameters File.
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN (BIDFN).
; 2 - BISITE (req) IEN of Site (often the user's DUZ(2)).
;
N BIPCC,BIGPRA,BIERR S BIERR=""
I '$G(BIDFN) D ERRCD^BIUTL2(201,.BIERR) Q 0
S:'$G(BISITE) BISITE=$G(DUZ(2))
I '$G(BISITE) D ERRCD^BIUTL2(109,.BIERR) Q 0
S BIPCC=+$$CURCOM(BIDFN)
Q:'BIPCC 0
D GETGPRA^BISITE4(.BIGPRA,BISITE,.BIERR)
I BIERR]"" Q 0
Q:$D(BIGPRA(BIPCC)) 1
Q 0
;
;
;----------
NEXTAPPT(BIDFN) ;EP
;---> Return patient's next appointment from Scheduling Package.
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN (BIDFN).
;
Q:'$G(BIDFN) ""
Q:'$D(^DPT(BIDFN)) ""
;
N BIAPPT,BIDT,BIYES
S BIDT=DT+.2400,BIYES=0
F S BIDT=$O(^DPT(BIDFN,"S",BIDT)) Q:'BIDT!(BIYES) D
.N BIDATA,BIOI,X
.S BIDATA=$G(^DPT(BIDFN,"S",BIDT,0))
.Q:BIDATA=""
.;
.;---> Quit if appointment is cancelled.
.Q:$P(BIDATA,U,2)["C"
.;
.S X=0 F S X=$O(^SC(+BIDATA,"S",BIDT,1,X)) Q:'X D
..Q:+$G(^SC(+BIDATA,"S",BIDT,1,X,0))'=BIDFN
..S BIYES=BIDT_U_+BIDATA
;
Q:'BIYES "None"
;
S BIAPPT=$$FMTE^XLFDT(+BIYES,"1P")_" with "
S BIAPPT=BIAPPT_$P($G(^SC($P(BIYES,U,2),0)),U)
Q BIAPPT
;
;
;----------
LASTIMM(BIDFN,BICVXS,BIQDT,BIALL) ;PEP - Return latest date patient received CVX vaccine(s).
;---> Return the latest Fileman date on which any one of the CVX's in the
;---> string BICVXS was received. Return 0 (zero) if none received.
;---> Parameters:
; 1 - BIDFN (req) IEN of Patient in ^DPT.
; 2 - BICVXS (req) String of CVX Codes to check, delimited by comma.
; 3 - BIQDT (opt) Quarter Ending Date (ignore Visits after this date).
; 4 - BIALL (opt) If BIALL=1 return string of dates (comma delim) before BIQDT.
; 5 - BIVG (opt) *NOT USED* Vaccine Group (if BIVG=IEN of Vaccine Group, check that way).
;
Q:'$G(BIDFN) 0
Q:'$G(BICVXS) 0
N BICVX,BIDATE,I S BIDATE=0
;
F I=1:1 S BICVX=$P(BICVXS,",",I) Q:BICVX="" D
.S BIIEN=$$HL7TX^BIUTL2(BICVX)
.;---> Quit if CVX Code does not exist in Vaccine Table (or=OTHER).
.Q:('BIIEN!(BIIEN=137)) 0
.N N S N=0
.F S N=$O(^AUPNVIMM("AC",BIDFN,N)) Q:'N D
..N X,Y S X=$G(^AUPNVIMM(N,0))
..;---> Quit if this visit doesn't match the desired CVX Code.
..Q:(+X'=BIIEN)
..;
..;---> Get pointer to Visit (to get date of visit).
..S Y=$P(X,U,3)
..Q:'Y
..S Y=$P(+$G(^AUPNVSIT(Y,0)),".")
..Q:'Y
..;---> Quit if this Visit was after the Quarter Ending Date.
..I $G(BIQDT) Q:(Y>BIQDT)
..;
..;---> If returning all dates, concat string and quit.
..I $G(BIALL) D Q
...I BIDATE S BIDATE=BIDATE_","_Y Q
...S BIDATE=Y
..;
..;---> If only returning last date, reset BIDATE if this is later than any prior BIDATE.
..S:(Y>BIDATE) BIDATE=Y
;
;---> Return the latest Visit Date for this set of CVX Codes.
Q BIDATE
;
;
;----------
LASTCPT(BIDFN,BICPTS,BIQDT,BIALL) ;EP
;---> Return the latest Fileman date on which any one of the CPT's in the
;---> string BICPTS was received. Return 0 (zero) if none received.
;---> Parameters:
; 1 - BIDFN (req) Patient DFN
; 2 - BICPTS (req) String of CPT Codes to check, delimited by comma.
; 3 - BIQDT (opt) Quarter Ending Date (ignore Visits after this date).
; 4 - BIALL (opt) If BIALL=1 return string of dates (comma delim) before BIQDT.
;
Q:'$G(BIDFN) 0
Q:'$G(BICPTS) 0
N BICPT,BIDATE,I S BIDATE=0
F I=1:1 S BICPT=$P(BICPTS,",",I) Q:BICPT="" D
.N N S N=0
.F S N=$O(^AUPNVCPT("AA",BIDFN,BICPT,N)) Q:'N D
..N BIDATE1 S BIDATE1=9999999-N
..I $G(BIQDT) Q:(BIDATE1>BIQDT)
..;
..;---> If returning all dates, concat string and quit.
..I $G(BIALL) D Q
...I BIDATE S BIDATE=BIDATE_","_BIDATE1 Q
...S BIDATE=BIDATE1
..;
..;---> If only returning last date, reset BIDATE if this is later than any prior BIDATE.
..S:(BIDATE1>BIDATE) BIDATE=BIDATE1
;
;---> Return the latest Visit Date for this set of CPT Codes.
Q BIDATE
;
;
;----------
MOTHMAID(DFN) ;EP
;---> CodeChange for v7.1 - IHS/CMI/MWR 12/01/2000:
;---> This is a new call added.
;---> Return patient's mother's maiden name.
;---> Parameters:
; 1 - DFN (req) Patient's IEN (DFN).
;
Q:'$G(DFN) "No DFN"
Q $P($G(^DPT(DFN,.24)),U,3)
;
;
;********** PATCH 9, v8.5, OCT 01,2014, IHS/CMI/MWR
;---> Call to limit export of imms to specific vaccines within a date range.
;----------
GOTDOSE(BIDFN,BIVIEN,BIRDT) ;EP
;---> Return 1 if patient received one or more doses of the input vaccine
;---> within the givin date range; otherwise return 0.
;---> Parameters:
; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
; 2 - BIVIEN (req) IEN of Vaccine.
; 3 - BIRDT (opt) Date range in Fileman format YYYMMDD:YYYMMDD
;
Q:'$G(BIDFN) 0
Q:'$G(BIVIEN) 0 Q:'$D(^AUTTIMM(BIVIEN,0)) 0
;
N BISDT,BIEDT
S BISDT=+$P($G(BIRDT),":")
S BIEDT=+$P($G(BIRDT),":",2) I BIEDT=0 S BIEDT=9999999
;
N N,Z S N=0,Z=0
F S N=$O(^AUPNVIMM("AC",BIDFN,N)) Q:'N Q:Z D
.N X,Y S X=$G(^AUPNVIMM(N,0))
.;---> Quit if this visit doesn't match the desired vaccine.
.Q:(+X'=BIVIEN)
.;
.;---> Get pointer to Visit (to get date of visit).
.S Y=$P(X,U,3)
.Q:'Y
.S Y=$P(+$G(^AUPNVSIT(Y,0)),".")
.Q:'Y
.;---> Quit if this Visit was before the Start Date.
.Q:(Y<BISDT)
.;---> Quit if this Visit was after the End Date.
.Q:(Y>BIEDT)
.;---> Got a dose.
.S Z=1
;
Q Z
BIUTL11 ;IHS/CMI/MWR - UTIL: PATIENT INFO; AUG 10,2010
+1 ;;8.5;IMMUNIZATION;**9**;OCT 01,2014
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; UTILITY: PATIENT FUNCTIONS: CONTRAS, INPATIENT, HIDOSE.
+4 ;; PATCH 1: Correct typo "Q", so that unmatched CVX returns 0 (zero),
+5 ;; not "Q". LASTIMM+17
+6 ;; PATCH 3: Append date to Hx of Chickenpox Reason. CONTRA+45
+7 ;; PATCH 5: Unused call, was never a P.E.P.. CONTR+0
+8 ;; PATCH 8: For Hx of Chicken Pox, do NOT contraindicate Zoster (CVX=121). CONTRA+62
+9 ;; PATCH 9: Add GOTDOSE call: check if patient received a dose. GOTDOSE+0
+10 ;
+11 ;
+12 ;----------
CONTRA(BIDFN,A,BIREF,BIDATE) ;EP
+1 ;---> Return an array of a patient's ImmServe Contraindications.
+2 ;---> Called by IMMSERV^BIEXPRT5.
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
+5 ; 2 - A (ret) Array with subscripts=HL7 CVX Codes of vaccines
+6 ; contraindicated for this patient.
+7 ; Each node A(CVX)=IEN of the Reason in ^BICONT(
+8 ; 3 - BIREF (opt) If BIREF=1, return only Vaccines contraindicated
+9 ; because they were refused, i.e., Refusals.
+10 ; If BIREF=2, return only Vaccines contraindicated
+11 ; because of Hx of Chicken Pox.
+12 ; 4 - BIDATE (opt) If BIDATE=1, append Date of contra to Refusals.
+13 ;
+14 IF '$GET(BIDFN)
QUIT
+15 ;---> Quit if there are no contraindications for this patient.
+16 IF '$DATA(^BIPC("B",BIDFN))
QUIT
+17 ;
+18 NEW N,U
SET N=0
SET U="^"
+19 FOR
SET N=$ORDER(^BIPC("B",BIDFN,N))
IF 'N
QUIT
Begin DoDot:1
+20 ;---> If bad xref, kill it and quit.
+21 IF '$DATA(^BIPC(N,0))
KILL ^BIPC("B",BIDFN,N)
QUIT
+22 NEW BIPC,X,Y
+23 ;---> BIPC=zero node of a Patient's Contraindication.
+24 SET BIPC=^BIPC(N,0)
+25 ;
+26 ;---> Set X=Reason pointer (to ^BICONT), Y=Date of Contraindication.
+27 SET X=$PIECE(BIPC,U,3)
SET Y=$PIECE(BIPC,U,4)
+28 ;
+29 ;---> If the call is to return an array of Refusals, do so and quit.
+30 IF $GET(BIREF)=1
Begin DoDot:2
+31 ;---> 11 & 16 are IENs of BI TABLE CONTRA REASONS ^BICONT( that are REFUSALS.
+32 IF (X=11)!(X=16)
Begin DoDot:3
+33 ;---> Set array node A(CVX)=IEN of Refusal Contra Reason.
+34 NEW Z
SET Z=$PIECE(BIPC,U,2)
IF Z
SET Z=$GET(^AUTTIMM(Z,0))
SET Z=$PIECE(Z,U,3)
+35 IF Z
SET A(Z)=X
IF $GET(BIDATE)
SET A(Z)=A(Z)_U_Y
End DoDot:3
QUIT
End DoDot:2
QUIT
+36 ;
+37 ;
+38 ;---> If the call is to return an array of Hx of Chicken Pox, do so and quit.
+39 IF $GET(BIREF)=2
Begin DoDot:2
+40 ;---> 12 is the IEN of BI TABLE CONTRA REASONS that is Hx of Chicken Pox.
+41 IF X=12
Begin DoDot:3
+42 ;---> Set array node A(CVX)=IEN of Hx of Chicken Pox Reason.
+43 ;
+44 ;********** PATCH 3, v8.5, SEP 10,2012, IHS/CMI/MWR
+45 ;---> Append date to Hx of Chickenpox Reason.
+46 NEW Z
SET Z=$PIECE(BIPC,U,2)
IF Z
SET Z=$GET(^AUTTIMM(Z,0))
SET Z=$PIECE(Z,U,3)
+47 IF Z
SET A(Z)=X
IF $GET(BIDATE)
SET A(Z)=A(Z)_U_Y
+48 ;**********
End DoDot:3
QUIT
End DoDot:2
QUIT
+49 ;
+50 ;---> Continue in order to return an array of contra'd vaccines by CVX Code.
+51 ;
+52 ;---> Quit if the Reason for this contraindication is one that
+53 ;---> still allows forecasting of the vaccine. For example,
+54 ;---> if the reason is "Patient Refusal", then the vaccine should
+55 ;---> still be forecast as due.
+56 IF X
IF $PIECE($GET(^BICONT(X,0)),U,2)
QUIT
+57 ;
+58 ;---> For this Vaccine IEN contraindication, get Related Contraindcated CVX Codes.
+59 ;---> (Call below also sets A(CVX) of THIS Vaccine IEN in the A(CVX) array.)
+60 DO CONTRHL7($PIECE(BIPC,U,2),.A)
+61 ;
+62 ;********** PATCH 8, v8.5, MAR 15,2014, IHS/CMI/MWR
+63 ;---> If the vaccine is Varicella (CVX=21) and Reason is Hx of Chicken Pox,
+64 ;---> do NOT contraindicate Zoster (CVX=121).
+65 IF $PIECE(BIPC,U,2)=132
IF $PIECE(BIPC,U,3)=12
KILL A(121)
+66 ;**********
End DoDot:1
+67 ;
+68 QUIT
+69 ;
+70 ;
+71 ;----------
CONTRHL7(BIVAC,A) ;EP
+1 ;---> Return an array of Related Contraindcated HL7 Codes for
+2 ;---> this vaccine.
+3 ;---> Parameters:
+4 ; 1 - BIVAC (req) IEN of Vaccine.
+5 ; 2 - A (ret) Array with subscripts=HL7 Codes of vaccines
+6 ; contraindicated that relate to this vaccine.
+7 ;
+8 IF '$GET(BIVAC)
QUIT
IF '$DATA(^AUTTIMM(BIVAC,0))
QUIT
+9 ;
+10 ;---> Set X=data for this vaccine.
+11 NEW X
SET X=^AUTTIMM(BIVAC,0)
+12 ;
+13 ;---> Set HL7 Code for this contraindicated vaccine in A() array
+14 ;---> as a subscript.
+15 IF '$PIECE(X,U,3)
QUIT
+16 SET A($PIECE(X,U,3))=""
+17 ;
+18 ;---> Set X=string of Related Contraindicated HL7 Codes for this
+19 ;---> vaccine.
+20 SET X=$PIECE(X,U,12)
+21 ;
+22 ;---> Now piece out Contraindicated HL7 Codes (comma delimited)
+23 ;---> and set in A() array as subscripts.
+24 NEW I,Y
FOR I=1:1
SET Y=$PIECE(X,",",I)
IF 'Y
QUIT
SET A(Y)=""
+25 QUIT
+26 ;
+27 ;
+28 ;----------
CONTR(BIDFN,BIVAC) ;EP
+1 ;
+2 ;********** PATCH 5, v8.5, JUL 01,2013, IHS/CMI/MWR
+3 ;---> REMOVED. Was never a P.E.P.
+4 QUIT
+5 ;
+6 ;
+7 ;----------
INPT(BIDFN,BIDATE) ;EP
+1 ;---> Return 1 if patient was an inpatient on BIDATE.
+2 ;---> Called by +84^BIVISIT to correct Category.
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
+5 ; 2 - BIDATE (req) Date to check if patient was inpatient.
+6 ;
+7 IF '$GET(BIDFN)
QUIT 0
IF '$GET(BIDATE)
QUIT 0
+8 ;
+9 ;---> Get last discharge previous to BIDATE.
+10 NEW X,Y
SET BIDATE=9999999.9999999-BIDATE
+11 SET X=$ORDER(^AUPNVINP("AA",BIDFN,BIDATE))
+12 ;
+13 ;---> Now check to see if patient has been admitted since
+14 ;---> that discharge date.
+15 SET X=$ORDER(^AUPNVSIT("AAH",BIDFN,X),-1)
+16 ;
+17 ;---> If patient not admitted since last discharge, quit 0.
+18 IF 'X
QUIT 0
+19 ;
+20 ;---> If Visit is for Contract Care, quit 0 (not an inpatient).
+21 ;---> Next line v8.1 fix: Use X (inv date) to get Y (IEN).
+22 SET Y=+$ORDER(^AUPNVSIT("AAH",BIDFN,X,0))
+23 IF $PIECE($GET(^AUPNVSIT(Y,0)),U,3)="C"
QUIT 0
+24 ;
+25 ;---> If last admission was after BIDATE (inverse), quit 0.
+26 IF X<BIDATE
QUIT 0
+27 ;
+28 ;---> Patient was an inpatient on BIDATE, quit 1.
+29 QUIT 1
+30 ;
+31 ;
+32 ;----------
INFL(BIDFN,TEXT) ;EP
+1 ;---> Return value of Patient's Forecast Influ/Pneumo field.
+2 ;---> 0=Normal, 1=Influenza, 2=Pneumococcal, 3=Both, 4=Disregard Risk Factors.
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) Patient's IEN (BIDFN).
+5 ; 2 - TEXT (opt) If TEXT=1, return text of the field.
+6 ;
+7 IF '$GET(BIDFN)
QUIT 0
+8 IF '$DATA(^BIP(BIDFN,0))
QUIT 0
+9 NEW X
SET X=+$PIECE(^BIP(BIDFN,0),U,15)
+10 IF '$GET(TEXT)
QUIT X
+11 IF X=4
QUIT "Disregard Risk Factors"
+12 IF X=3
QUIT "Influenza and Pneumo"
+13 IF X=2
QUIT "Pneumococcal"
+14 IF X=1
QUIT "Influenza"
+15 QUIT "Normal"
+16 ;
+17 ;
+18 ;----------
MOTHER(BIDFN,BITEXT) ;EP
+1 ;---> Return mother's HBsAg Status Code.
+2 ;---> Parameters:
+3 ; 1 - BIDFN (req) Patient's IEN (BIDFN).
+4 ; 2 - BITEXT (opt) If BITEXT=1 return full text.
+5 NEW X
+6 Begin DoDot:1
+7 IF '$GET(BIDFN)
SET X="U"
QUIT
+8 IF '$DATA(^BIP(BIDFN,0))
SET X="U"
QUIT
+9 SET X=$PIECE(^BIP(BIDFN,0),U,11)
End DoDot:1
+10 IF X=""
SET X="U"
+11 IF '$GET(BITEXT)
QUIT X
+12 QUIT $SELECT(X="P":"POSITIVE",X="N":"NEGATIVE",1:"UNKNOWN")
+13 ;
+14 ;
+15 ;----------
BENTYP(BIDFN,TEXT) ;EP
+1 ;---> Return IEN of Patient's Beneficiary Type.
+2 ;---> This is the CLASSIFICATION/BENEFICIARY Code (Item 2 on page 2
+3 ;---> of Registration).
+4 ;---> Parameters:
+5 ; 1 - BIDFN (req) Patient's IEN (DFN).
+6 ;---> Text parameter added.
+7 ; 2 - TEXT (opt) If TEXT=1, return text of Beneficiary Type.
+8 ; If text=2, return Code of Beneficiary Type. vvv83
+9 ;
+10 NEW Y
+11 IF '$GET(BIDFN)
QUIT 0
+12 SET Y=+$PIECE($GET(^AUPNPAT(BIDFN,11)),U,11)
+13 IF '$GET(TEXT)
QUIT Y
+14 ;vvv83
IF $GET(TEXT)=2
QUIT $PIECE($GET(^AUTTBEN(Y,0)),U,2)
+15 QUIT $PIECE($GET(^AUTTBEN(Y,0)),U)
+16 ;
+17 ;
+18 ;----------
OTHERIN(BIDFN) ;EP
+1 ;---> Return Patient's Other Info.
+2 ;---> Parameters:
+3 ; 1 - BIDFN (req) Patient's IEN (BIDFN).
+4 ;
+5 IF '$GET(BIDFN)
QUIT ""
+6 QUIT $PIECE($GET(^BIP(BIDFN,0)),U,13)
+7 ;
+8 ;
+9 ;----------
MAYEDIT() ;EP
+1 ;---> Return 1 if User has Immunization Edit Patients Key; 0 if not.
+2 IF '$DATA(DUZ)
QUIT 0
+3 IF $DATA(^XUSEC("BIZ EDIT PATIENTS",DUZ))
QUIT 1
+4 IF $DATA(^XUSEC("BIZ MANAGER",DUZ))
QUIT 1
+5 QUIT 0
+6 ;
+7 ;
+8 ;----------
MAYMANAG() ;EP
+1 ;---> Return 1 if User has Immunization Manager Key; 0 if not.
+2 IF '$DATA(DUZ)
QUIT 0
+3 IF $DATA(^XUSEC("BIZ MANAGER",DUZ))
QUIT 1
+4 QUIT 0
+5 ;
+6 ;
+7 ;----------
CURCOM(BIDFN,TEXT) ;EP
+1 ;---> Return patient's Current Community IEN or Text.
+2 ;---> (Item 6 on page 1 of Registration).
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) Patient's IEN (BIDFN).
+5 ; 2 - TEXT (opt) If TEXT=1, return text of Current Community.
+6 ;
+7 IF '$GET(BIDFN)
QUIT "No Patient"
+8 IF '$DATA(^AUPNPAT(BIDFN,11))
QUIT "Unknown1"
+9 ;
+10 NEW X,Y,Z
+11 SET X=^AUPNPAT(BIDFN,11)
+12 ;---> Set Y=Pointer (IEN in ^AUTTCOM, piece 17), Z=Text (piece 18).
+13 SET Y=$PIECE(X,U,17)
SET Z=$PIECE(X,U,18)
+14 ;---> If both Pointer and Text are null, return "Unknown2".
+15 IF ('Y&(Z=""))
QUIT "Unknown2"
+16 ;
+17 ;---> If Y is null or a bad pointer, set Y="".
+18 IF Y<1!('$DATA(^AUTTCOM(+Y,0)))
SET Y=""
+19 ;
+20 ;---> If no valid pointer and if Text (pc 18) exists in the
+21 ;---> Community file, then set Y=IEN in ^AUTTCOM(, and fix it.
+22 IF Y<1
IF $DATA(^AUTTCOM("B",Z))
SET Y=$ORDER(^AUTTCOM("B",Z,0))
Begin DoDot:1
+23 NEW BIFLD
SET BIFLD(1117)=Y
DO FDIE^BIFMAN(9000001,BIDFN,.BIFLD)
End DoDot:1
+24 ;
+25 IF '$DATA(^AUTTCOM(+Y,0))
QUIT "Unknown3"
+26 ;
+27 NEW BITEXT
SET BITEXT=$PIECE(^AUTTCOM(Y,0),U)
+28 ;---> If text field is off, fix it.
+29 IF Z'=BITEXT
Begin DoDot:1
+30 NEW BIFLD
SET BIFLD(1118)=BITEXT
DO FDIE^BIFMAN(9000001,BIDFN,.BIFLD)
End DoDot:1
+31 IF '$GET(TEXT)
QUIT Y
+32 QUIT $PIECE(^AUTTCOM(Y,0),U)
+33 ;
+34 ;
+35 ;----------
ISGPRA(BIDFN,BISITE,BINOCOM,BIERR) ;PEP - Return 1 if Pt's Current Community is in Imm GPRA Set.
+1 ;---> Return 1 if Patient's Current Community is in the Immunization GPRA Set
+2 ;---> of Communities as defined in the BI Site Parameters File.
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) Patient's IEN (BIDFN).
+5 ; 2 - BISITE (req) IEN of Site (often the user's DUZ(2)).
+6 ;
+7 NEW BIPCC,BIGPRA,BIERR
SET BIERR=""
+8 IF '$GET(BIDFN)
DO ERRCD^BIUTL2(201,.BIERR)
QUIT 0
+9 IF '$GET(BISITE)
SET BISITE=$GET(DUZ(2))
+10 IF '$GET(BISITE)
DO ERRCD^BIUTL2(109,.BIERR)
QUIT 0
+11 SET BIPCC=+$$CURCOM(BIDFN)
+12 IF 'BIPCC
QUIT 0
+13 DO GETGPRA^BISITE4(.BIGPRA,BISITE,.BIERR)
+14 IF BIERR]""
QUIT 0
+15 IF $DATA(BIGPRA(BIPCC))
QUIT 1
+16 QUIT 0
+17 ;
+18 ;
+19 ;----------
NEXTAPPT(BIDFN) ;EP
+1 ;---> Return patient's next appointment from Scheduling Package.
+2 ;---> Parameters:
+3 ; 1 - BIDFN (req) Patient's IEN (BIDFN).
+4 ;
+5 IF '$GET(BIDFN)
QUIT ""
+6 IF '$DATA(^DPT(BIDFN))
QUIT ""
+7 ;
+8 NEW BIAPPT,BIDT,BIYES
+9 SET BIDT=DT+.2400
SET BIYES=0
+10 FOR
SET BIDT=$ORDER(^DPT(BIDFN,"S",BIDT))
IF 'BIDT!(BIYES)
QUIT
Begin DoDot:1
+11 NEW BIDATA,BIOI,X
+12 SET BIDATA=$GET(^DPT(BIDFN,"S",BIDT,0))
+13 IF BIDATA=""
QUIT
+14 ;
+15 ;---> Quit if appointment is cancelled.
+16 IF $PIECE(BIDATA,U,2)["C"
QUIT
+17 ;
+18 SET X=0
FOR
SET X=$ORDER(^SC(+BIDATA,"S",BIDT,1,X))
IF 'X
QUIT
Begin DoDot:2
+19 IF +$GET(^SC(+BIDATA,"S",BIDT,1,X,0))'=BIDFN
QUIT
+20 SET BIYES=BIDT_U_+BIDATA
End DoDot:2
End DoDot:1
+21 ;
+22 IF 'BIYES
QUIT "None"
+23 ;
+24 SET BIAPPT=$$FMTE^XLFDT(+BIYES,"1P")_" with "
+25 SET BIAPPT=BIAPPT_$PIECE($GET(^SC($PIECE(BIYES,U,2),0)),U)
+26 QUIT BIAPPT
+27 ;
+28 ;
+29 ;----------
LASTIMM(BIDFN,BICVXS,BIQDT,BIALL) ;PEP - Return latest date patient received CVX vaccine(s).
+1 ;---> Return the latest Fileman date on which any one of the CVX's in the
+2 ;---> string BICVXS was received. Return 0 (zero) if none received.
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) IEN of Patient in ^DPT.
+5 ; 2 - BICVXS (req) String of CVX Codes to check, delimited by comma.
+6 ; 3 - BIQDT (opt) Quarter Ending Date (ignore Visits after this date).
+7 ; 4 - BIALL (opt) If BIALL=1 return string of dates (comma delim) before BIQDT.
+8 ; 5 - BIVG (opt) *NOT USED* Vaccine Group (if BIVG=IEN of Vaccine Group, check that way).
+9 ;
+10 IF '$GET(BIDFN)
QUIT 0
+11 IF '$GET(BICVXS)
QUIT 0
+12 NEW BICVX,BIDATE,I
SET BIDATE=0
+13 ;
+14 FOR I=1:1
SET BICVX=$PIECE(BICVXS,",",I)
IF BICVX=""
QUIT
Begin DoDot:1
+15 SET BIIEN=$$HL7TX^BIUTL2(BICVX)
+16 ;---> Quit if CVX Code does not exist in Vaccine Table (or=OTHER).
+17 IF ('BIIEN!(BIIEN=137))
QUIT 0
+18 NEW N
SET N=0
+19 FOR
SET N=$ORDER(^AUPNVIMM("AC",BIDFN,N))
IF 'N
QUIT
Begin DoDot:2
+20 NEW X,Y
SET X=$GET(^AUPNVIMM(N,0))
+21 ;---> Quit if this visit doesn't match the desired CVX Code.
+22 IF (+X'=BIIEN)
QUIT
+23 ;
+24 ;---> Get pointer to Visit (to get date of visit).
+25 SET Y=$PIECE(X,U,3)
+26 IF 'Y
QUIT
+27 SET Y=$PIECE(+$GET(^AUPNVSIT(Y,0)),".")
+28 IF 'Y
QUIT
+29 ;---> Quit if this Visit was after the Quarter Ending Date.
+30 IF $GET(BIQDT)
IF (Y>BIQDT)
QUIT
+31 ;
+32 ;---> If returning all dates, concat string and quit.
+33 IF $GET(BIALL)
Begin DoDot:3
+34 IF BIDATE
SET BIDATE=BIDATE_","_Y
QUIT
+35 SET BIDATE=Y
End DoDot:3
QUIT
+36 ;
+37 ;---> If only returning last date, reset BIDATE if this is later than any prior BIDATE.
+38 IF (Y>BIDATE)
SET BIDATE=Y
End DoDot:2
End DoDot:1
+39 ;
+40 ;---> Return the latest Visit Date for this set of CVX Codes.
+41 QUIT BIDATE
+42 ;
+43 ;
+44 ;----------
LASTCPT(BIDFN,BICPTS,BIQDT,BIALL) ;EP
+1 ;---> Return the latest Fileman date on which any one of the CPT's in the
+2 ;---> string BICPTS was received. Return 0 (zero) if none received.
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) Patient DFN
+5 ; 2 - BICPTS (req) String of CPT Codes to check, delimited by comma.
+6 ; 3 - BIQDT (opt) Quarter Ending Date (ignore Visits after this date).
+7 ; 4 - BIALL (opt) If BIALL=1 return string of dates (comma delim) before BIQDT.
+8 ;
+9 IF '$GET(BIDFN)
QUIT 0
+10 IF '$GET(BICPTS)
QUIT 0
+11 NEW BICPT,BIDATE,I
SET BIDATE=0
+12 FOR I=1:1
SET BICPT=$PIECE(BICPTS,",",I)
IF BICPT=""
QUIT
Begin DoDot:1
+13 NEW N
SET N=0
+14 FOR
SET N=$ORDER(^AUPNVCPT("AA",BIDFN,BICPT,N))
IF 'N
QUIT
Begin DoDot:2
+15 NEW BIDATE1
SET BIDATE1=9999999-N
+16 IF $GET(BIQDT)
IF (BIDATE1>BIQDT)
QUIT
+17 ;
+18 ;---> If returning all dates, concat string and quit.
+19 IF $GET(BIALL)
Begin DoDot:3
+20 IF BIDATE
SET BIDATE=BIDATE_","_BIDATE1
QUIT
+21 SET BIDATE=BIDATE1
End DoDot:3
QUIT
+22 ;
+23 ;---> If only returning last date, reset BIDATE if this is later than any prior BIDATE.
+24 IF (BIDATE1>BIDATE)
SET BIDATE=BIDATE1
End DoDot:2
End DoDot:1
+25 ;
+26 ;---> Return the latest Visit Date for this set of CPT Codes.
+27 QUIT BIDATE
+28 ;
+29 ;
+30 ;----------
MOTHMAID(DFN) ;EP
+1 ;---> CodeChange for v7.1 - IHS/CMI/MWR 12/01/2000:
+2 ;---> This is a new call added.
+3 ;---> Return patient's mother's maiden name.
+4 ;---> Parameters:
+5 ; 1 - DFN (req) Patient's IEN (DFN).
+6 ;
+7 IF '$GET(DFN)
QUIT "No DFN"
+8 QUIT $PIECE($GET(^DPT(DFN,.24)),U,3)
+9 ;
+10 ;
+11 ;********** PATCH 9, v8.5, OCT 01,2014, IHS/CMI/MWR
+12 ;---> Call to limit export of imms to specific vaccines within a date range.
+13 ;----------
GOTDOSE(BIDFN,BIVIEN,BIRDT) ;EP
+1 ;---> Return 1 if patient received one or more doses of the input vaccine
+2 ;---> within the givin date range; otherwise return 0.
+3 ;---> Parameters:
+4 ; 1 - BIDFN (req) Patient's IEN in VA PATIENT File #2.
+5 ; 2 - BIVIEN (req) IEN of Vaccine.
+6 ; 3 - BIRDT (opt) Date range in Fileman format YYYMMDD:YYYMMDD
+7 ;
+8 IF '$GET(BIDFN)
QUIT 0
+9 IF '$GET(BIVIEN)
QUIT 0
IF '$DATA(^AUTTIMM(BIVIEN,0))
QUIT 0
+10 ;
+11 NEW BISDT,BIEDT
+12 SET BISDT=+$PIECE($GET(BIRDT),":")
+13 SET BIEDT=+$PIECE($GET(BIRDT),":",2)
IF BIEDT=0
SET BIEDT=9999999
+14 ;
+15 NEW N,Z
SET N=0
SET Z=0
+16 FOR
SET N=$ORDER(^AUPNVIMM("AC",BIDFN,N))
IF 'N
QUIT
IF Z
QUIT
Begin DoDot:1
+17 NEW X,Y
SET X=$GET(^AUPNVIMM(N,0))
+18 ;---> Quit if this visit doesn't match the desired vaccine.
+19 IF (+X'=BIVIEN)
QUIT
+20 ;
+21 ;---> Get pointer to Visit (to get date of visit).
+22 SET Y=$PIECE(X,U,3)
+23 IF 'Y
QUIT
+24 SET Y=$PIECE(+$GET(^AUPNVSIT(Y,0)),".")
+25 IF 'Y
QUIT
+26 ;---> Quit if this Visit was before the Start Date.
+27 IF (Y<BISDT)
QUIT
+28 ;---> Quit if this Visit was after the End Date.
+29 IF (Y>BIEDT)
QUIT
+30 ;---> Got a dose.
+31 SET Z=1
End DoDot:1
+32 ;
+33 QUIT Z
