Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BIRPC4

BIRPC4.m

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