BIRPC4 ;IHS/CMI/MWR - REMOTE PROCEDURE CALLS; MAY 10, 2010
;;8.5;IMMUNIZATION;**5**;JUL 01,2013
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; ADD AND DELETE CONTRAINDICATIONS, EDIT PATIENT CASE DATA.
;; PATCH 5: Switch to logical deletions of Contraindications. DELCONT+14
;; PATCH 5: Add SNOMED Codes for Contraindication. ADDCONT+54, SNOMED
;
;
;----------
ADDCONT(BIERR,BIDATA) ;PEP - Add a Contraindication.
;---> Add Contraindication for a patient.
;---> Called by RPC: BI CONTRAINDICATION ADD.
;---> Parameters:
; 1 - BIERR (ret) Text of Error Code if any, otherwise null.
; 2 - BIDATA (req) String of data for the Contraindication to be added.
; Data elements are parsed by "|" as follows:
; Patient IEN|Vaccine IEN|Contra Reason IEN|Date Noted|Edit Flag
;
;---> Define delimiter to pass error and error variable.
N BI31 S BI31=$C(31)_$C(31),BIERR=""
;
;---> If BIDATA not supplied, set Error Code and quit.
I $G(BIDATA)']"" D Q
.D ERRCD^BIUTL2(416,.BIERR) S BIERR=BI31_BIERR
;
;---> Break out BIDATA into pieces.
N BICRIEN,BIDATE,BIDFN,BIEDIT,BIMDEF,BIVIEN
S BIDFN=$P(BIDATA,"|",1) ;Patient DFN.
S BIVIEN=$P(BIDATA,"|",2) ;Vaccine IEN.
S BICRIEN=$P(BIDATA,"|",3) ;Contraindication Reason IEN.
S BIDATE=$P(BIDATA,"|",4) ;Date Noted.
S BIEDIT=$P(BIDATA,"|",5) ;If BIEDIT=1, this is an Edit.
;
;---> If valid Patient DFN not provided, set Error Code and quit.
I ('BIDFN)!('$D(^AUPNPAT(BIDFN,0))) D Q
.D ERRCD^BIUTL2(417,.BIERR) S BIERR=BI31_BIERR
;
;---> If valid Vaccine IEN not provided, set Error Code and quit.
I ('BIVIEN)!('$D(^AUTTIMM(BIVIEN,0))) D Q
.D ERRCD^BIUTL2(418,.BIERR) S BIERR=BI31_BIERR
;
;---> If IEN for Contra Reason is not valid, set Error Code and quit.
I BICRIEN I '$D(^BICONT(BICRIEN,0)) D Q
.D ERRCD^BIUTL2(419,.BIERR) S BIERR=BI31_BIERR
;
;---> Check if Contra already exists for this reason; quit if duplicate.
N BIQUIT,N,X S BIQUIT=0
I '$G(BIEDIT) D
.S X=BIDFN_"^"_BIVIEN_"^"_BICRIEN
.S N=0
.F S N=$O(^BIPC("B",BIDFN,N)) Q:'N Q:BIQUIT D
..I $P(^BIPC(N,0),U,1,3)=X S BIQUIT=1 D Q
...D ERRCD^BIUTL2(439,.BIERR) S BIERR=BI31_BIERR
Q:BIQUIT
;
;---> If this patient is Immune Deficient, use BIMDEF array below
;---> to add other live vaccines as contraindicated.
I $P($G(^BICONT(+BICRIEN,0)),U)="Immune Deficiency" D
.S BIMDEF("C")=BICRIEN,BIMDEF("D")=BIDATE
;
;
;---> ADD Contraindication.
;
;********** PATCH 5, v8.5, JUL 01,2013, IHS/CMI/MWR
;---> Add SNOMED Codes for this Contraindication.
;N BIERR,BIFLD
N BIERR,BIFLD,BIIEN
S BIFLD(.01)=BIDFN,BIFLD(.02)=BIVIEN,BIFLD(.03)=BICRIEN,BIFLD(.04)=BIDATE
;D UPDATE^BIFMAN(9002084.11,,.BIFLD,.BIERR)
D UPDATE^BIFMAN(9002084.11,.BIIEN,.BIFLD,.BIERR)
;
;---> If add of Contra is successful, BIIEN(1)=IEN of new Patient Contra,
;---> so add SNOMED Codes.
D:(+$G(BIIEN(1)))
.N I,X,Y
.;---> Get string of Vaccine Component IEN's.
.S X=$$VCOMPS^BIUTL2(BIVIEN)
.;---> If no components process the vaccine itself.
.S:('+X) X=BIVIEN
.;
.F I=1:1:6 S Y=$P(X,";",I) Q:'Y D
..;---> Get Vaccine Group IEN of this vaccine.
..N BIVGRP S BIVGRP=$$IMMVG^BIUTL2(Y)
..;---> Quit if Vaccine Group is Other, Skin Test, or Combo.
..Q:((BIVGRP=12)!(BIVGRP=13)!(BIVGRP=14)!(BIVGRP<1))
..;---> Call Lori's Magic Mapper to get SNOMED Code.
..D SNOMED(BIVGRP,BICRIEN,BIIEN(1))
;
;**********
;
;---> If add contraindication fails, set Error Code and quit.
I $G(BIERR)]"" D Q
.N X S X=BIERR
.D ERRCD^BIUTL2(420,.BIERR) S BIERR=BI31_BIERR_" "_X
;
;---> If this is a Refusal, add it to PATIENT REFUSALS FOR SERVICE/NMI
;---> File #9000022.
D:((BICRIEN=11)!(BICRIEN=16))
.N BIREFI S BIREFI=$$VNAME^BIUTL2(BIVIEN)_" - "_$$CONTXT^BIUTL6(BICRIEN)
.D REFUSAL("IMMUNIZATION",BIDFN,BIDATE,BIREFI,9999999.14,BIVIEN,"R",$G(DUZ))
;
;
;---> Add Adverse Reaction to ART Package.
;---> Sept 2005: Not possible at this time.
I (BICRIEN=4)!(BICRIEN=8)!(BICRIEN=9) D
.;SEND EVENT(?) TO ART PACKAGE.
;
;---> Quit if this patient is not Immune Deficient.
Q:'$D(BIMDEF)
;
;---> Patient is Immune Deficient, so add MMR, Varicella, & Flu-Nasal
;---> contraindications.
;---> Imm v8.5: added all Rotavirus, per Ros.
N BIHL7
F BIHL7=3,21,111,74,116,119,122 D
.N BIIEN,DR S BIIEN=$$HL7TX^BIUTL2(BIHL7)
.;
.N BIADD,N S N=0,BIADD=1
.;---> Loop through patient's existing contraindications.
.F S N=$O(^BIPC("B",BIDFN,N)) Q:'N Q:'BIADD D
..N X S X=$G(^BIPC(N,0))
..Q:'X
..;---> Quit (BIADD=0) if this contra & reason already exists.
..I $P(X,U,2)=BIIEN&($P(X,U,3)=BIMDEF("C")) S BIADD=0
.Q:'BIADD
.;
.;---> Add contraindication with a reason of Immune Deficiency.
.N BIERR,BIFLD
.S BIFLD(.01)=BIDFN,BIFLD(.02)=BIIEN
.S BIFLD(.03)=BIMDEF("C"),BIFLD(.04)=BIMDEF("D")
.D UPDATE^BIFMAN(9002084.11,,.BIFLD,.BIERR)
Q
;
;
;********** PATCH 5, v8.5, JUL 01,2013, IHS/CMI/MWR
;---> Add SNOMED Codes for this Contraindication.
;----------
SNOMED(BIVGRP,BICRIEN,BIIEN) ;PP - Add SNOMED data.
;---> File SNOMED data for this Contraindication.
;---> Parameters:
; 1 - BIVGRP (req) Vaccine Group IEN.
; 2 - BICRIEN (req) Contraindication Reason IEN.
; 3 - BIIEN (req) Patient Contraindication IEN.
;
Q:'$G(BIVGRP) Q:'$G(BICRIEN) Q:'$G(BIIEN)
N BICODES,Z
;---> Call Mapper to set up BICODES Array of SNOMED Code(s).
;---> Quit if BCQM not installed.
Q:('$L($T(MM^BCQMAPI)))
;---> First clear out old SNOMED Codes for this Contra if they exist.
K ^BIPC(BIIEN,1)
;---> Get array of Codes for this entry.
S Z=$$MM^BCQMAPI(9002084.81,BICRIEN,"I",BIVGRP,,,,,,,"BICODES")
N BIFDA,J S J=0
F S J=$O(BICODES(J)) Q:'J D
.N BISNOMED S BISNOMED=BICODES(J,"SNOMED")
.S BIFDA(9002084.111,"+"_J_","_BIIEN_",",.01)=BISNOMED
;---> Now file these.
D UPDATE^DIE("","BIFDA")
Q
;**********
;
;----------
DELCONT(BIERR,BICIEN) ;PEP - Add a Contraindication.
;---> Delete a Contraindication.
;---> Called by RPC: BI CONTRAINDICATION DELETE.
;---> Parameters:
; 1 - BIERR (ret) Text of Error Code if any, otherwise null.
; 2 - BICIEN (req) IEN of BI CONTRAINDICATION to be deleted.
;
;---> Define delimiter to pass error and error variable.
N BI31 S BI31=$C(31)_$C(31),BIERR=""
;
;---> If DA not supplied, set Error Code and quit.
I '$G(BICIEN) D Q
.D ERRCD^BIUTL2(414,.BIERR) S BIERR=BI31_BIERR
;
;
;********** PATCH 5, v8.5, JUL 01,2013, IHS/CMI/MWR
;---> Switch to logical deletion of Contraindications.
;---> First copy Contra nodes to Deleted file, then delete Contra.
;
;---> Quit if bad IEN for Contra.
I '$D(^BIPC(BICIEN,0)) D Q
.D ERRCD^BIUTL2(448,.BIERR) S BIERR=BI31_BIERR
;---> Quit if bad Patient DFN for Contra.
N BIDFN,BINODE
S BINODE=^BIPC(BICIEN,0),BIDFN=$P(BINODE,U)
I 'BIDFN D Q
.D ERRCD^BIUTL2(417,.BIERR) S BIERR=BI31_BIERR
;
;---> Create an entry in BI PATIENT CONTRAINDICATION DELETED File.
N BIERR,BIIEN,BIFLD
S BIFLD(.01)=BIDFN
S BIFLD(.02)=$P(BINODE,U,2)
S BIFLD(.03)=$P(BINODE,U,3)
S BIFLD(.04)=$P(BINODE,U,4)
S BIFLD(2.01)=+$G(DUZ)
D NOW^%DTC S BIFLD(2.02)=%
D UPDATE^BIFMAN(9002084.115,.BIIEN,.BIFLD,.BIERR)
;---> Quit if new entry failed.
I BIERR]"" S BIERR=BI31_BIERR Q
;---> Quit if new entry IEN bad.
I '$D(^BIPCD(+BIIEN(1),0)) D Q
.D ERRCD^BIUTL2(449,.BIERR) S BIERR=BI31_BIERR
;**********
;
;---> Okay, now delete BI CONTRAINDICATION entry.
N DA,DIK S DA=BICIEN,DIK="^BIPC("
D ^DIK
;
;---> Don't need to copy SNOMED fields, but save for prototype code.
;I $D(^BIPC(BICIEN,1,0)) S ^BIPCD(BIIEN,1,0)=^BIPC(BICIEN,1,0)
;N N S N=0 F S N=$O(^BIPC(BICIEN,1,N)) Q:'N D
;.N BISNO S BISNO=^BIPC(BICIEN,1,N,0),^BIPCD(BIIEN,1,N,0)=BISNO
;.S ^BIPCD(BIIEN,1,"B",BISNO,N)=""
;**********
;
Q
;
;
;----------
EDITCAS(BIERR,BIDATA) ;EP
;---> Edit a Patient's Case Data.
;---> Called by RPC: BI ?
;---> Parameters:
; 1 - BIERR (ret) Text of Error Code if any, otherwise null.
; 2 - BIDATA (req) String of Patient's Case Data to be edited.
;
;---> Define delimiter to pass error and error variable.
N BI31,U S BI31=$C(31)_$C(31),BIERR="",U="^"
;
;---> If BIDATA not supplied, set Error Code and quit.
I $G(BIDATA)']"" D Q
.D ERRCD^BIUTL2(207,.BIERR) S BIERR=BI31_BIERR
;
;---> Break out BIDATA into pieces.
N A,B,C,D,E,F,G,H,I,J
S A=$P(BIDATA,U,1) ;Patient DFN.
S B=$P(BIDATA,U,2) ;IEN of Case Manager.
S C=$P(BIDATA,U,3) ;Parent or Guardian, text.
S D=$P(BIDATA,U,4) ;Mother's HBsAG Status (P,N,A,U).
S E=$P(BIDATA,U,5) ;Date Patient became Inactive (external format).
S F=$P(BIDATA,U,6) ;Reason for Inactive.
S G=$P(BIDATA,U,7) ;Other Info.
S H=$P(BIDATA,U,8) ;Forecast Influ/Pneumo.
S I=$P(BIDATA,U,9) ;Location Moved or Tx Elsewhere.
S J=$P(BIDATA,U,10) ;IEN of User who Inactivated this patient.
S K=$P(BIDATA,U,11) ;Consent State Registry.
;
;---> If valid Patient DFN not provided, set Error Code and quit.
I ('A)!('$D(^BIP(+A,0))) D Q
.D ERRCD^BIUTL2(206,.BIERR) S BIERR=BI31_BIERR
;
;---> If Case Manager is null (possibly deleted), send @ to delete.
S:'B B="@"
;
;---> If valid Case Manager IEN not provided, set Error Code and quit.
I B&('$D(^BIMGR(+B,0))) D Q
.D ERRCD^BIUTL2(208,.BIERR) S BIERR=BI31_BIERR
;
;---> If Case Manager is INACTIVE, set Error Code and quit.
I B,$$CMGRACT^BIUTL2(B) D Q
.D ERRCD^BIUTL2(213,.BIERR) S BIERR=BI31_BIERR
;
;---> If Inactive Date was set but no Reason given, set Error Code and quit.
I (E]"")&(F="") D Q
.D ERRCD^BIUTL2(219,.BIERR) S BIERR=BI31_BIERR
;
;---> If Parent or Guardian="" or was deleted, set C="@" to delete.
S:C="" C="@" S C=$$TR(.C)
;
;---> If Mother's HGsAG Status not valid, set to null.
S:"PANU"'[D D=""
;
;---> If Inactive Date is null (possibly deleted), send @ to delete.
;---> If Date is valid, convert to Fileman format.
D
.I E="" S E="@" Q
.N %DT,X,Y S X=E
.D ^%DT S E=Y
;
;---> If Inactive Date=@, set Reason for Inactive and Inactivated by User
;---> both ="" (E,F="" to delete).
S:(E="@"!(F="")) (F,J)="" S F=$$TR(.F)
;
;---> If Date is invalid, set Error Code and quit.
I E=-1 D Q
.D ERRCD^BIUTL2(209,.BIERR) S BIERR=BI31_BIERR
;
;---> If Other Info="" or was deleted, set G="@" to delete.
S:G="" G="@" S G=$$TR(.G)
;
;---> If Forecast Influ/Pneumo is not valid, set to null.
S:"01234"'[H H="" S:H="" H="@"
;
;---> Build FDA field=value array.
N BIFLD
S BIFLD(.08)=E
S BIFLD(.09)=C
S BIFLD(.1)=B
S BIFLD(.11)=D
S BIFLD(.12)=I
S BIFLD(.13)=G
S BIFLD(.15)=H
S BIFLD(.16)=F
S BIFLD(.23)=J
S BIFLD(.24)=K
;
;---> Store edit data.
D FDIE^BIFMAN(9002084,+A,.BIFLD,.BIERR)
S:BIERR["" BIERR=BI31_BIERR
Q
;
;
;----------
REFUSAL(BIREFT,BIDFN,BIDATE,BIREFI,BIREFF,BIREFV,BIREFR,BIPROV,BIERR) ;EP
;---> Add a Refusal to the PATIENT REFUSALS FOR SERVICE/NMI File #9000022.
;---> Parameters:
; 1 - BIREFT (req) Text of Refusal Type in REFUSAL TYPE File #9999999.73.
; 2 - BIDFN (req) Patient DFN, .02.
; 3 - BIDATE (req) Date (Fman) refused or not indicated, .03.
; 4 - BIREFI (req) Refusal Item (80 characters of free text), .04.
; 5 - BIREFF (req) Pointer file (Immunization #9999999.14), .05
; 6 - BIREFV (req) Pointer Value (IEN of vaccine in #9999999.14), .06
; 7 - BIREFR (opt) Reason for Refusal (set of codes), .07
; 8 - BIPROV (opt) Provider IEN, 1204,
; 9 - BIERR (ret) Text of Error Code if any, otherwise null.
;
N BIREFT1 S BIREFT1=$O(^AUTTREFT("B",BIREFT,0))
;---> Quit if there isn't a good pointer to the Refusal Type file.
I 'BIREFT1 D ERRCD^BIUTL2(440,.BIERR) Q
;
;---> First check for duplicate refusal already on file.
N BIFLD,BIQUIT,N,X S BIQUIT=0
S X=BIREFT1_"^"_BIDFN_"^"_BIDATE_"^"_BIREFI
S N=0
F S N=$O(^AUPNPREF("AC",BIDFN,N)) Q:'N Q:BIQUIT D
.I $P(^AUPNPREF(N,0),U,1,4)=X S BIQUIT=1 Q
Q:BIQUIT
;
;---> Okay, no duplicates; store this in Patient Refusals file.
;
S BIFLD(.01)=BIREFT1,BIFLD(.02)=BIDFN,BIFLD(.03)=BIDATE,BIFLD(.04)=BIREFI
S BIFLD(.05)=BIREFF,BIFLD(.06)=BIREFV,BIFLD(.07)=BIREFR,BIFLD(1204)=BIPROV
D UPDATE^BIFMAN(9000022,,.BIFLD,.BIERR)
Q
;
;
;----------
TR(X) ;EP
;---> Translate any ";" to ",", so that DR string will parse
;---> correctly.
;---> Parameters:
; 1 - X (req) String to be scanned for ";".
;
S X=$TR($G(X),";",",")
Q X
BIRPC4 ;IHS/CMI/MWR - REMOTE PROCEDURE CALLS; MAY 10, 2010
+1 ;;8.5;IMMUNIZATION;**5**;JUL 01,2013
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; ADD AND DELETE CONTRAINDICATIONS, EDIT PATIENT CASE DATA.
+4 ;; PATCH 5: Switch to logical deletions of Contraindications. DELCONT+14
+5 ;; PATCH 5: Add SNOMED Codes for Contraindication. ADDCONT+54, SNOMED
+6 ;
+7 ;
+8 ;----------
ADDCONT(BIERR,BIDATA) ;PEP - Add a Contraindication.
+1 ;---> Add Contraindication for a patient.
+2 ;---> Called by RPC: BI CONTRAINDICATION ADD.
+3 ;---> Parameters:
+4 ; 1 - BIERR (ret) Text of Error Code if any, otherwise null.
+5 ; 2 - BIDATA (req) String of data for the Contraindication to be added.
+6 ; Data elements are parsed by "|" as follows:
+7 ; Patient IEN|Vaccine IEN|Contra Reason IEN|Date Noted|Edit Flag
+8 ;
+9 ;---> Define delimiter to pass error and error variable.
+10 NEW BI31
SET BI31=$CHAR(31)_$CHAR(31)
SET BIERR=""
+11 ;
+12 ;---> If BIDATA not supplied, set Error Code and quit.
+13 IF $GET(BIDATA)']""
Begin DoDot:1
+14 DO ERRCD^BIUTL2(416,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:1
QUIT
+15 ;
+16 ;---> Break out BIDATA into pieces.
+17 NEW BICRIEN,BIDATE,BIDFN,BIEDIT,BIMDEF,BIVIEN
+18 ;Patient DFN.
SET BIDFN=$PIECE(BIDATA,"|",1)
+19 ;Vaccine IEN.
SET BIVIEN=$PIECE(BIDATA,"|",2)
+20 ;Contraindication Reason IEN.
SET BICRIEN=$PIECE(BIDATA,"|",3)
+21 ;Date Noted.
SET BIDATE=$PIECE(BIDATA,"|",4)
+22 ;If BIEDIT=1, this is an Edit.
SET BIEDIT=$PIECE(BIDATA,"|",5)
+23 ;
+24 ;---> If valid Patient DFN not provided, set Error Code and quit.
+25 IF ('BIDFN)!('$DATA(^AUPNPAT(BIDFN,0)))
Begin DoDot:1
+26 DO ERRCD^BIUTL2(417,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:1
QUIT
+27 ;
+28 ;---> If valid Vaccine IEN not provided, set Error Code and quit.
+29 IF ('BIVIEN)!('$DATA(^AUTTIMM(BIVIEN,0)))
Begin DoDot:1
+30 DO ERRCD^BIUTL2(418,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:1
QUIT
+31 ;
+32 ;---> If IEN for Contra Reason is not valid, set Error Code and quit.
+33 IF BICRIEN
IF '$DATA(^BICONT(BICRIEN,0))
Begin DoDot:1
+34 DO ERRCD^BIUTL2(419,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:1
QUIT
+35 ;
+36 ;---> Check if Contra already exists for this reason; quit if duplicate.
+37 NEW BIQUIT,N,X
SET BIQUIT=0
+38 IF '$GET(BIEDIT)
Begin DoDot:1
+39 SET X=BIDFN_"^"_BIVIEN_"^"_BICRIEN
+40 SET N=0
+41 FOR
SET N=$ORDER(^BIPC("B",BIDFN,N))
IF 'N
QUIT
IF BIQUIT
QUIT
Begin DoDot:2
+42 IF $PIECE(^BIPC(N,0),U,1,3)=X
SET BIQUIT=1
Begin DoDot:3
+43 DO ERRCD^BIUTL2(439,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+44 IF BIQUIT
QUIT
+45 ;
+46 ;---> If this patient is Immune Deficient, use BIMDEF array below
+47 ;---> to add other live vaccines as contraindicated.
+48 IF $PIECE($GET(^BICONT(+BICRIEN,0)),U)="Immune Deficiency"
Begin DoDot:1
+49 SET BIMDEF("C")=BICRIEN
SET BIMDEF("D")=BIDATE
End DoDot:1
+50 ;
+51 ;
+52 ;---> ADD Contraindication.
+53 ;
+54 ;********** PATCH 5, v8.5, JUL 01,2013, IHS/CMI/MWR
+55 ;---> Add SNOMED Codes for this Contraindication.
+56 ;N BIERR,BIFLD
+57 NEW BIERR,BIFLD,BIIEN
+58 SET BIFLD(.01)=BIDFN
SET BIFLD(.02)=BIVIEN
SET BIFLD(.03)=BICRIEN
SET BIFLD(.04)=BIDATE
+59 ;D UPDATE^BIFMAN(9002084.11,,.BIFLD,.BIERR)
+60 DO UPDATE^BIFMAN(9002084.11,.BIIEN,.BIFLD,.BIERR)
+61 ;
+62 ;---> If add of Contra is successful, BIIEN(1)=IEN of new Patient Contra,
+63 ;---> so add SNOMED Codes.
+64 IF (+$GET(BIIEN(1)))
Begin DoDot:1
+65 NEW I,X,Y
+66 ;---> Get string of Vaccine Component IEN's.
+67 SET X=$$VCOMPS^BIUTL2(BIVIEN)
+68 ;---> If no components process the vaccine itself.
+69 IF ('+X)
SET X=BIVIEN
+70 ;
+71 FOR I=1:1:6
SET Y=$PIECE(X,";",I)
IF 'Y
QUIT
Begin DoDot:2
+72 ;---> Get Vaccine Group IEN of this vaccine.
+73 NEW BIVGRP
SET BIVGRP=$$IMMVG^BIUTL2(Y)
+74 ;---> Quit if Vaccine Group is Other, Skin Test, or Combo.
+75 IF ((BIVGRP=12)!(BIVGRP=13)!(BIVGRP=14)!(BIVGRP<1))
QUIT
+76 ;---> Call Lori's Magic Mapper to get SNOMED Code.
+77 DO SNOMED(BIVGRP,BICRIEN,BIIEN(1))
End DoDot:2
End DoDot:1
+78 ;
+79 ;**********
+80 ;
+81 ;---> If add contraindication fails, set Error Code and quit.
+82 IF $GET(BIERR)]""
Begin DoDot:1
+83 NEW X
SET X=BIERR
+84 DO ERRCD^BIUTL2(420,.BIERR)
SET BIERR=BI31_BIERR_" "_X
End DoDot:1
QUIT
+85 ;
+86 ;---> If this is a Refusal, add it to PATIENT REFUSALS FOR SERVICE/NMI
+87 ;---> File #9000022.
+88 IF ((BICRIEN=11)!(BICRIEN=16))
Begin DoDot:1
+89 NEW BIREFI
SET BIREFI=$$VNAME^BIUTL2(BIVIEN)_" - "_$$CONTXT^BIUTL6(BICRIEN)
+90 DO REFUSAL("IMMUNIZATION",BIDFN,BIDATE,BIREFI,9999999.14,BIVIEN,"R",$GET(DUZ))
End DoDot:1
+91 ;
+92 ;
+93 ;---> Add Adverse Reaction to ART Package.
+94 ;---> Sept 2005: Not possible at this time.
+95 IF (BICRIEN=4)!(BICRIEN=8)!(BICRIEN=9)
Begin DoDot:1
+96 ;SEND EVENT(?) TO ART PACKAGE.
End DoDot:1
+97 ;
+98 ;---> Quit if this patient is not Immune Deficient.
+99 IF '$DATA(BIMDEF)
QUIT
+100 ;
+101 ;---> Patient is Immune Deficient, so add MMR, Varicella, & Flu-Nasal
+102 ;---> contraindications.
+103 ;---> Imm v8.5: added all Rotavirus, per Ros.
+104 NEW BIHL7
+105 FOR BIHL7=3,21,111,74,116,119,122
Begin DoDot:1
+106 NEW BIIEN,DR
SET BIIEN=$$HL7TX^BIUTL2(BIHL7)
+107 ;
+108 NEW BIADD,N
SET N=0
SET BIADD=1
+109 ;---> Loop through patient's existing contraindications.
+110 FOR
SET N=$ORDER(^BIPC("B",BIDFN,N))
IF 'N
QUIT
IF 'BIADD
QUIT
Begin DoDot:2
+111 NEW X
SET X=$GET(^BIPC(N,0))
+112 IF 'X
QUIT
+113 ;---> Quit (BIADD=0) if this contra & reason already exists.
+114 IF $PIECE(X,U,2)=BIIEN&($PIECE(X,U,3)=BIMDEF("C"))
SET BIADD=0
End DoDot:2
+115 IF 'BIADD
QUIT
+116 ;
+117 ;---> Add contraindication with a reason of Immune Deficiency.
+118 NEW BIERR,BIFLD
+119 SET BIFLD(.01)=BIDFN
SET BIFLD(.02)=BIIEN
+120 SET BIFLD(.03)=BIMDEF("C")
SET BIFLD(.04)=BIMDEF("D")
+121 DO UPDATE^BIFMAN(9002084.11,,.BIFLD,.BIERR)
End DoDot:1
+122 QUIT
+123 ;
+124 ;
+125 ;********** PATCH 5, v8.5, JUL 01,2013, IHS/CMI/MWR
+126 ;---> Add SNOMED Codes for this Contraindication.
+127 ;----------
SNOMED(BIVGRP,BICRIEN,BIIEN) ;PP - Add SNOMED data.
+1 ;---> File SNOMED data for this Contraindication.
+2 ;---> Parameters:
+3 ; 1 - BIVGRP (req) Vaccine Group IEN.
+4 ; 2 - BICRIEN (req) Contraindication Reason IEN.
+5 ; 3 - BIIEN (req) Patient Contraindication IEN.
+6 ;
+7 IF '$GET(BIVGRP)
QUIT
IF '$GET(BICRIEN)
QUIT
IF '$GET(BIIEN)
QUIT
+8 NEW BICODES,Z
+9 ;---> Call Mapper to set up BICODES Array of SNOMED Code(s).
+10 ;---> Quit if BCQM not installed.
+11 IF ('$LENGTH($TEXT(MM^BCQMAPI)))
QUIT
+12 ;---> First clear out old SNOMED Codes for this Contra if they exist.
+13 KILL ^BIPC(BIIEN,1)
+14 ;---> Get array of Codes for this entry.
+15 SET Z=$$MM^BCQMAPI(9002084.81,BICRIEN,"I",BIVGRP,,,,,,,"BICODES")
+16 NEW BIFDA,J
SET J=0
+17 FOR
SET J=$ORDER(BICODES(J))
IF 'J
QUIT
Begin DoDot:1
+18 NEW BISNOMED
SET BISNOMED=BICODES(J,"SNOMED")
+19 SET BIFDA(9002084.111,"+"_J_","_BIIEN_",",.01)=BISNOMED
End DoDot:1
+20 ;---> Now file these.
+21 DO UPDATE^DIE("","BIFDA")
+22 QUIT
+23 ;**********
+24 ;
+25 ;----------
DELCONT(BIERR,BICIEN) ;PEP - Add a Contraindication.
+1 ;---> Delete a Contraindication.
+2 ;---> Called by RPC: BI CONTRAINDICATION DELETE.
+3 ;---> Parameters:
+4 ; 1 - BIERR (ret) Text of Error Code if any, otherwise null.
+5 ; 2 - BICIEN (req) IEN of BI CONTRAINDICATION to be deleted.
+6 ;
+7 ;---> Define delimiter to pass error and error variable.
+8 NEW BI31
SET BI31=$CHAR(31)_$CHAR(31)
SET BIERR=""
+9 ;
+10 ;---> If DA not supplied, set Error Code and quit.
+11 IF '$GET(BICIEN)
Begin DoDot:1
+12 DO ERRCD^BIUTL2(414,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:1
QUIT
+13 ;
+14 ;
+15 ;********** PATCH 5, v8.5, JUL 01,2013, IHS/CMI/MWR
+16 ;---> Switch to logical deletion of Contraindications.
+17 ;---> First copy Contra nodes to Deleted file, then delete Contra.
+18 ;
+19 ;---> Quit if bad IEN for Contra.
+20 IF '$DATA(^BIPC(BICIEN,0))
Begin DoDot:1
+21 DO ERRCD^BIUTL2(448,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:1
QUIT
+22 ;---> Quit if bad Patient DFN for Contra.
+23 NEW BIDFN,BINODE
+24 SET BINODE=^BIPC(BICIEN,0)
SET BIDFN=$PIECE(BINODE,U)
+25 IF 'BIDFN
Begin DoDot:1
+26 DO ERRCD^BIUTL2(417,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:1
QUIT
+27 ;
+28 ;---> Create an entry in BI PATIENT CONTRAINDICATION DELETED File.
+29 NEW BIERR,BIIEN,BIFLD
+30 SET BIFLD(.01)=BIDFN
+31 SET BIFLD(.02)=$PIECE(BINODE,U,2)
+32 SET BIFLD(.03)=$PIECE(BINODE,U,3)
+33 SET BIFLD(.04)=$PIECE(BINODE,U,4)
+34 SET BIFLD(2.01)=+$GET(DUZ)
+35 DO NOW^%DTC
SET BIFLD(2.02)=%
+36 DO UPDATE^BIFMAN(9002084.115,.BIIEN,.BIFLD,.BIERR)
+37 ;---> Quit if new entry failed.
+38 IF BIERR]""
SET BIERR=BI31_BIERR
QUIT
+39 ;---> Quit if new entry IEN bad.
+40 IF '$DATA(^BIPCD(+BIIEN(1),0))
Begin DoDot:1
+41 DO ERRCD^BIUTL2(449,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:1
QUIT
+42 ;**********
+43 ;
+44 ;---> Okay, now delete BI CONTRAINDICATION entry.
+45 NEW DA,DIK
SET DA=BICIEN
SET DIK="^BIPC("
+46 DO ^DIK
+47 ;
+48 ;---> Don't need to copy SNOMED fields, but save for prototype code.
+49 ;I $D(^BIPC(BICIEN,1,0)) S ^BIPCD(BIIEN,1,0)=^BIPC(BICIEN,1,0)
+50 ;N N S N=0 F S N=$O(^BIPC(BICIEN,1,N)) Q:'N D
+51 ;.N BISNO S BISNO=^BIPC(BICIEN,1,N,0),^BIPCD(BIIEN,1,N,0)=BISNO
+52 ;.S ^BIPCD(BIIEN,1,"B",BISNO,N)=""
+53 ;**********
+54 ;
+55 QUIT
+56 ;
+57 ;
+58 ;----------
EDITCAS(BIERR,BIDATA) ;EP
+1 ;---> Edit a Patient's Case Data.
+2 ;---> Called by RPC: BI ?
+3 ;---> Parameters:
+4 ; 1 - BIERR (ret) Text of Error Code if any, otherwise null.
+5 ; 2 - BIDATA (req) String of Patient's Case Data to be edited.
+6 ;
+7 ;---> Define delimiter to pass error and error variable.
+8 NEW BI31,U
SET BI31=$CHAR(31)_$CHAR(31)
SET BIERR=""
SET U="^"
+9 ;
+10 ;---> If BIDATA not supplied, set Error Code and quit.
+11 IF $GET(BIDATA)']""
Begin DoDot:1
+12 DO ERRCD^BIUTL2(207,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:1
QUIT
+13 ;
+14 ;---> Break out BIDATA into pieces.
+15 NEW A,B,C,D,E,F,G,H,I,J
+16 ;Patient DFN.
SET A=$PIECE(BIDATA,U,1)
+17 ;IEN of Case Manager.
SET B=$PIECE(BIDATA,U,2)
+18 ;Parent or Guardian, text.
SET C=$PIECE(BIDATA,U,3)
+19 ;Mother's HBsAG Status (P,N,A,U).
SET D=$PIECE(BIDATA,U,4)
+20 ;Date Patient became Inactive (external format).
SET E=$PIECE(BIDATA,U,5)
+21 ;Reason for Inactive.
SET F=$PIECE(BIDATA,U,6)
+22 ;Other Info.
SET G=$PIECE(BIDATA,U,7)
+23 ;Forecast Influ/Pneumo.
SET H=$PIECE(BIDATA,U,8)
+24 ;Location Moved or Tx Elsewhere.
SET I=$PIECE(BIDATA,U,9)
+25 ;IEN of User who Inactivated this patient.
SET J=$PIECE(BIDATA,U,10)
+26 ;Consent State Registry.
SET K=$PIECE(BIDATA,U,11)
+27 ;
+28 ;---> If valid Patient DFN not provided, set Error Code and quit.
+29 IF ('A)!('$DATA(^BIP(+A,0)))
Begin DoDot:1
+30 DO ERRCD^BIUTL2(206,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:1
QUIT
+31 ;
+32 ;---> If Case Manager is null (possibly deleted), send @ to delete.
+33 IF 'B
SET B="@"
+34 ;
+35 ;---> If valid Case Manager IEN not provided, set Error Code and quit.
+36 IF B&('$DATA(^BIMGR(+B,0)))
Begin DoDot:1
+37 DO ERRCD^BIUTL2(208,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:1
QUIT
+38 ;
+39 ;---> If Case Manager is INACTIVE, set Error Code and quit.
+40 IF B
IF $$CMGRACT^BIUTL2(B)
Begin DoDot:1
+41 DO ERRCD^BIUTL2(213,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:1
QUIT
+42 ;
+43 ;---> If Inactive Date was set but no Reason given, set Error Code and quit.
+44 IF (E]"")&(F="")
Begin DoDot:1
+45 DO ERRCD^BIUTL2(219,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:1
QUIT
+46 ;
+47 ;---> If Parent or Guardian="" or was deleted, set C="@" to delete.
+48 IF C=""
SET C="@"
SET C=$$TR(.C)
+49 ;
+50 ;---> If Mother's HGsAG Status not valid, set to null.
+51 IF "PANU"'[D
SET D=""
+52 ;
+53 ;---> If Inactive Date is null (possibly deleted), send @ to delete.
+54 ;---> If Date is valid, convert to Fileman format.
+55 Begin DoDot:1
+56 IF E=""
SET E="@"
QUIT
+57 NEW %DT,X,Y
SET X=E
+58 DO ^%DT
SET E=Y
End DoDot:1
+59 ;
+60 ;---> If Inactive Date=@, set Reason for Inactive and Inactivated by User
+61 ;---> both ="" (E,F="" to delete).
+62 IF (E="@"!(F=""))
SET (F,J)=""
SET F=$$TR(.F)
+63 ;
+64 ;---> If Date is invalid, set Error Code and quit.
+65 IF E=-1
Begin DoDot:1
+66 DO ERRCD^BIUTL2(209,.BIERR)
SET BIERR=BI31_BIERR
End DoDot:1
QUIT
+67 ;
+68 ;---> If Other Info="" or was deleted, set G="@" to delete.
+69 IF G=""
SET G="@"
SET G=$$TR(.G)
+70 ;
+71 ;---> If Forecast Influ/Pneumo is not valid, set to null.
+72 IF "01234"'[H
SET H=""
IF H=""
SET H="@"
+73 ;
+74 ;---> Build FDA field=value array.
+75 NEW BIFLD
+76 SET BIFLD(.08)=E
+77 SET BIFLD(.09)=C
+78 SET BIFLD(.1)=B
+79 SET BIFLD(.11)=D
+80 SET BIFLD(.12)=I
+81 SET BIFLD(.13)=G
+82 SET BIFLD(.15)=H
+83 SET BIFLD(.16)=F
+84 SET BIFLD(.23)=J
+85 SET BIFLD(.24)=K
+86 ;
+87 ;---> Store edit data.
+88 DO FDIE^BIFMAN(9002084,+A,.BIFLD,.BIERR)
+89 IF BIERR[""
SET BIERR=BI31_BIERR
+90 QUIT
+91 ;
+92 ;
+93 ;----------
REFUSAL(BIREFT,BIDFN,BIDATE,BIREFI,BIREFF,BIREFV,BIREFR,BIPROV,BIERR) ;EP
+1 ;---> Add a Refusal to the PATIENT REFUSALS FOR SERVICE/NMI File #9000022.
+2 ;---> Parameters:
+3 ; 1 - BIREFT (req) Text of Refusal Type in REFUSAL TYPE File #9999999.73.
+4 ; 2 - BIDFN (req) Patient DFN, .02.
+5 ; 3 - BIDATE (req) Date (Fman) refused or not indicated, .03.
+6 ; 4 - BIREFI (req) Refusal Item (80 characters of free text), .04.
+7 ; 5 - BIREFF (req) Pointer file (Immunization #9999999.14), .05
+8 ; 6 - BIREFV (req) Pointer Value (IEN of vaccine in #9999999.14), .06
+9 ; 7 - BIREFR (opt) Reason for Refusal (set of codes), .07
+10 ; 8 - BIPROV (opt) Provider IEN, 1204,
+11 ; 9 - BIERR (ret) Text of Error Code if any, otherwise null.
+12 ;
+13 NEW BIREFT1
SET BIREFT1=$ORDER(^AUTTREFT("B",BIREFT,0))
+14 ;---> Quit if there isn't a good pointer to the Refusal Type file.
+15 IF 'BIREFT1
DO ERRCD^BIUTL2(440,.BIERR)
QUIT
+16 ;
+17 ;---> First check for duplicate refusal already on file.
+18 NEW BIFLD,BIQUIT,N,X
SET BIQUIT=0
+19 SET X=BIREFT1_"^"_BIDFN_"^"_BIDATE_"^"_BIREFI
+20 SET N=0
+21 FOR
SET N=$ORDER(^AUPNPREF("AC",BIDFN,N))
IF 'N
QUIT
IF BIQUIT
QUIT
Begin DoDot:1
+22 IF $PIECE(^AUPNPREF(N,0),U,1,4)=X
SET BIQUIT=1
QUIT
End DoDot:1
+23 IF BIQUIT
QUIT
+24 ;
+25 ;---> Okay, no duplicates; store this in Patient Refusals file.
+26 ;
+27 SET BIFLD(.01)=BIREFT1
SET BIFLD(.02)=BIDFN
SET BIFLD(.03)=BIDATE
SET BIFLD(.04)=BIREFI
+28 SET BIFLD(.05)=BIREFF
SET BIFLD(.06)=BIREFV
SET BIFLD(.07)=BIREFR
SET BIFLD(1204)=BIPROV
+29 DO UPDATE^BIFMAN(9000022,,.BIFLD,.BIERR)
+30 QUIT
+31 ;
+32 ;
+33 ;----------
TR(X) ;EP
+1 ;---> Translate any ";" to ",", so that DR string will parse
+2 ;---> correctly.
+3 ;---> Parameters:
+4 ; 1 - X (req) String to be scanned for ";".
+5 ;
+6 SET X=$TRANSLATE($GET(X),";",",")
+7 QUIT X
