BIUTLFIX ;IHS/CMI/MWR - UTIL: FIX STUFF.; AUG 10, 2010
;;8.5;IMMUNIZATION;**14**;AUG 01,2017
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; UTILITY: FIXES: LISTMAN HIDDEN MENUS.
;; PATCH 1: UPDATE VACCINE TABLE: ADD "INFLUENZA, 1203" CVX=123
;; PATCH 5: Back-populate SNOMED Codes to all Contraindications. SNOMED+0
;; PATCH 14: Update NOTE at BUILD+5 and date at BUILD+29
;; New rtn BITN3 to accommodate larger Vaccine Table BUILD+81
;
;
;----------
BUILD ;EP
;---> STEPS TO ADD NEW VACCINE TO VACCINE TABLE/IMMUNIZATION FILE:
;
;---> 1) Use Fileman to add new vaccine to the BI IMMUNIZATION TABLE
;---> HL7/CVX STANDARD File #9002084.94.
;---> NOTE: ^BITN nodes must have a 1 node (e.g., ^BITN(IEN,1)),
;---> easily done by populating the FULL NAME 1.14 field per CDC.
;
;---> 2) Execute line listed below to update ^BITN routine.
;---> (At programmer prompt, D BUILD^BIUTLFIX ZR X BIX0.)
;
;---> 3) Load BITN2 into an editor and trim the entire BITN routine
;---> that gets tacked onto the end of BITN2 during compilation.
;
;---> 4) Restandardize the Vaccine Table D RESTAND^BIRESTD().
;---> (Or under Manager Menu do MGR-->RES.)
;
;---> Build routine ^BITN.
;---> Not called by any option or User action. Used by package
;---> programmer to create routine BITN, which in turn is used
;---> to build ^BITN global during installation.
;---> To use: At programmer prompt, D BUILD^BIUTLFIX ZR X BIX0.
;
D SETVARS^BIUTL5
K BIXDT S BIXDT=$$TXDT^BIUTL5(DT)
S BIX0="N I F I=1:1 Q:'$D(@(""BIX""_I)) X @(""BIX""_I)"
;
;---> build first routine for nodes <200.
S BIX1="ZI ""BITN ;IHS/CMI/MWR - BUILD ^BITN GLOBAL."""
S BIX2="ZI "" ;;8.5;IMMUNIZATION;**14**;AUG 01,2017"""
S BIX3="ZI "" ;;* MICHAEL REMILLARD, DDS"
S BIX3=BIX3_" * CIMARRON MEDICAL INFORMATICS, FOR IHS *"""
S BIX4="ZI "" ;; UTILITY: BUILD STANDARD ^BITN GLOBAL."""
S BIX5="ZI "" ;"","" ;"","" ;----------"",""START ;EP"""
S BIX6="ZI "" D KGBL^BIUTL8(""""^BITN"""")"""
S BIX7="ZI "" S ^BITN(0)=""""BI IMMUNIZATION TABLE HL7 STANDARD"
S BIX7=BIX7_"^9002084.94I"""""""
;
S BIX8="ZI "" N I,X,Y,Z"""
S BIX9="ZI "" F I=1:2 S X=$T(@""""TABLE""""+I) Q:X'["""";;"""" D"""
S BIX10="ZI "" .S Y=$P(X,"""";;"""",2),Z=$P(X,"""";;"""",3)"""
S BIX11="ZI "" .S ^BITN(Y,0)=Z"" ZI "" .S X=$T(@""""TABLE""""+(I+1))"
S BIX11=BIX11_",Z=$P(X,"""";;"""",3),^BITN(Y,1)=Z"","" ;"""
;
;---> Next node for future inserts.
S BIX12=""
;
S BIX13="ZI "" F I=1:2 S X=$T(@""""TABLE""""+I^BITN2) Q:X'["""";;"""" D"""
S BIX14="ZI "" .S Y=$P(X,"""";;"""",2),Z=$P(X,"""";;"""",3)"""
S BIX15="ZI "" .S ^BITN(Y,0)=Z"" ZI "" .S X=$T(@""""TABLE""""+(I+1)^BITN2)"
S BIX15=BIX15_",Z=$P(X,"""";;"""",3),^BITN(Y,1)=Z"","" ;"""
;
S BIX16="ZI "" F I=1:2 S X=$T(@""""TABLE""""+I^BITN3) Q:X'["""";;"""" D"""
S BIX17="ZI "" .S Y=$P(X,"""";;"""",2),Z=$P(X,"""";;"""",3)"""
S BIX18="ZI "" .S ^BITN(Y,0)=Z"" ZI "" .S X=$T(@""""TABLE""""+(I+1)^BITN3)"
S BIX18=BIX18_",Z=$P(X,"""";;"""",3),^BITN(Y,1)=Z"","" ;"""
;
S BIX19="ZI "" N DIK S DIK=""""^BITN("""" D IXALL^DIK"""
S BIX20="ZI "" Q"","" ;"","" ;"","" ;----------"",""TABLE ; EP"""
S BIX21="N N S N=0 F S N=$O(^BITN(N)) Q:'N Q:(N>189) "
;S BIX18="N N S N=0 F S N=$O(^AUTTIMM(N)) Q:'N "
S BIX21=BIX21_"ZI "" ;;""_N_"";;""_^BITN(N,0)"
S BIX21=BIX21_" ZI "" ;;""_N_""a;;""_^BITN(N,1)"
S BIX22="ZS BITN ZR "
;
;---> Now build second routine for nodes >189.
S BIX23="ZI ""BITN2 ;IHS/CMI/MWR - BUILD ^BITN GLOBAL SECOND PART."""
S BIX24="ZI "" ;;8.5;IMMUNIZATION;**14**;AUG 01,2017"""
S BIX25="ZI "" ;;* MICHAEL REMILLARD, DDS"
S BIX25=BIX25_" * CIMARRON MEDICAL INFORMATICS, FOR IHS *"""
S BIX26="ZI "" ;; UTILITY: BUILD STANDARD ^BITN GLOBAL."""
S BIX27="ZI "" ;"","" ;"","" ;----------"",""TABLE ; EP"""
;S BIX25="N N S N=199 F S N=$O(^BITN(N)) Q:'N "
S BIX28="N N S N=189 F S N=$O(^BITN(N)) Q:'N Q:(N>259) "
S BIX28=BIX28_"ZI "" ;;""_N_"";;""_^BITN(N,0)"
S BIX28=BIX28_" ZI "" ;;""_N_""a;;""_^BITN(N,1)"
S BIX29="ZI "" Q"""
;S BIX27="ZS BITN2"
;S BIX28="W !,""DONE. Load and trim BITN2"""
S BIX30="ZS BITN2 ZR "
;
;********** PATCH 14, v8.5, AUG 01,2017, IHS/CMI/MWR
;---> New rtn BITN3 to accommodate larger Vaccine Table.
;---> Now build third routine for nodes >260.
S BIX31="ZI ""BITN3 ;IHS/CMI/MWR - BUILD ^BITN GLOBAL THIRD PART."""
S BIX32="ZI "" ;;8.5;IMMUNIZATION;**14**;AUG 01,2017"""
S BIX33="ZI "" ;;* MICHAEL REMILLARD, DDS"
S BIX33=BIX33_" * CIMARRON MEDICAL INFORMATICS, FOR IHS *"""
S BIX34="ZI "" ;; UTILITY: BUILD STANDARD ^BITN GLOBAL."""
S BIX35="ZI "" ;"","" ;"","" ;----------"",""TABLE ; EP"""
S BIX36="N N S N=259 F S N=$O(^BITN(N)) Q:'N "
S BIX36=BIX36_"ZI "" ;;""_N_"";;""_^BITN(N,0)"
S BIX36=BIX36_" ZI "" ;;""_N_""a;;""_^BITN(N,1)"
S BIX37="ZI "" Q"""
S BIX38="ZS BITN3 ZR "
S BIX39="W !,""DONE. Load and trim BITN2 and BITN3"""
Q
;
;
;********** PATCH 5, v8.5, JUL 01,2013, IHS/CMI/MWR
SNOMED ;PEP - Back-populate SNOMED Codes to all Contraindications.
;
N BIIEN S BIIEN=0 F S BIIEN=$O(^BIPC(BIIEN)) Q:'BIIEN D
.Q:'$D(^BIPC(BIIEN,0))
.N BICRIEN,BIVIEN,BIY
.S BIY=^BIPC(BIIEN,0)
.S BIVIEN=$P(BIY,U,2) ;Vaccine IEN.
.S BICRIEN=$P(BIY,U,3) ;Contraindication Reason IEN.
.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^BIRPC4(BIVGRP,BICRIEN,BIIEN)
Q
;**********
;
;
;----------
;---> Fix/update Listmanager hidden menus.
;---> This will go through all of the BI PROTOCOLS and update
;---> any hidden menus.
;
D ^XBKVAR
D LISTQUIT
N N S N="BI"
F S N=$O(^ORD(101,"B",N)) Q:N="" Q:N]"BIZZZ" D
.Q:N'["HIDDEN"
.N BIIEN S BIIEN=$O(^ORD(101,"B",N,0))
.D:BIIEN FIX(BIIEN)
Q
;
;
;----------
FIX(BIIEN) ;EP
Q:'BIIEN Q:'$D(^ORD(101,+BIIEN,0))
S XQORM=+BIIEN_";ORD(101,"
D XREF^XQORM
Q
;
;
;----------
LISTQUIT ;EP
;---> Set Quit synonym to "Q" on VALM HIDDEN ACTIONS Protocol.
;---> Get IEN of VALM HIDDEN ACTIONS Protocol.
N BIN S BIN=$O(^ORD(101,"B","VALM HIDDEN ACTIONS",0))
Q:'BIN
Q:$P(^ORD(101,BIN,0),U)'="VALM HIDDEN ACTIONS"
;
;---> Find "VALM QUIT" Item.
N N S N=0
F S N=$O(^ORD(101,BIN,10,N)) Q:'N D
.N X,Y
.S X=$P(^ORD(101,BIN,10,N,0),U)
.S Y=$P($G(^ORD(101,X,0)),U)
.Q:Y'="VALM QUIT"
.S $P(^ORD(101,BIN,10,N,0),U,2)="Q"
D FIX(BIN)
Q
;
;
;----------
ONE ;EP
;---> Individual Hidden Menu lookup.
W !!,"Select the Protocol you wish to fix.",!
D DIC^BIFMAN(101,"QEMA",.Y)
Q:Y<0
D FIX(+Y)
Q
;
;
;----------
BADPATS ;EP
;---> Look for BI PATIENTS with no data in ^BIP(BIDFN,0) node.
;
S N=0
F S N=$O(^BIP(N)) Q:'N D
.W:'$P(^BIP(N,0),"^") !,N,": ",^(0)
Q
;
;
;----------
ACTIVE ;EP
;---> Fix patients whose "Date Inactive" was erroneously converted.
;---> 1=Active, 0=Inactive.
;
N BITOTN,BITOTY
S N=0
S BITOTN=0,BITOTY=0
F S N=$O(^BIP(N)) Q:'N D
.I $P(^BIP(N,0),"^",8)=0 S $P(^(0),U,8)=DT S BITOTN=BITOTN+1 Q
.I $P(^BIP(N,0),"^",8)=1 S $P(^(0),U,8)="" S BITOTY=BITOTY+1
W !,"NO : ",BITOTN
W !,"YES: ",BITOTY
Q
;
;
;----------
CHGPTR(BICHG) ;EP
;---> Change all records with one vaccine pointer to a different one.
;---> Parameters:
; 1 - BICHG (opt) IF BICHG=1 then change entries from 214 to 235.
;
D SETVARS^BIUTL5
D KGBL^BIUTL8("^MIKE") S ^MIKE(0)=^AUPNVIMM(0)
N BICOUNT,BIECOUNT,BIN S BIN=0,BICOUNT=0,BIECOUNT=0
F S BIN=$O(^AUPNVIMM(BIN)) Q:'BIN D
.N BIERR S BIERR=0
.Q:($P(^AUPNVIMM(BIN,0),U)'=214)
.S BICOUNT=BICOUNT+1
.Q:('$G(BICHG))
.S ^MIKE(BIN,0)=^AUPNVIMM(BIN,0)
.;
.;---> Change .01 pointer to VAccine Table.
.N BIFLD S BIFLD(.01)=235
.D FDIE^BIFMAN(9000010.11,BIN,.BIFLD,.BIERR)
.I BIERR=1 S BIECOUNT=BIECOUNT+1,^MIKE("ERR",N)="" Q
;
W !!,"COUNT: ",BICOUNT
W !,"ERRORS: ",BIECOUNT
Q
;
;
;----------
CURCOM ;EP
;---> Utility to update Patients' Curren Community pointer, piece 17,
;---> based on text of Community in piece 18 of ^AUPNPAT(DFN,11).
;
N DFN,TOTAL
S DFN=0,TOTAL=0,U="^"
F S DFN=$O(^AUPNPAT(DFN)) Q:'DFN D
.N X,Y
.Q:'$D(^AUPNPAT(DFN,11))
.;
.;---> Quit if piece 17 is already set.
.Q:$P(^AUPNPAT(DFN,11),U,17)
.;
.;---> First try to get Current Community pointer from the last
.;---> "Community of Residence" Subfield of "Previous Community"
.;---> (Field .03 of the last/latest 51 subnode).
.N CC,N S CC="",N=0
.F S N=$O(^AUPNPAT(DFN,51,N)) Q:'N D
..S CC=$P($G(^AUPNPAT(DFN,51,N,0)),U,3)
.;
.;---> If the last Previous Community is a good pointer, use it & quit.
.I CC I $D(^AUTTCOM(CC,0)) D Q
..;---> Set the "CURRENT RESIDENCE PTR" Field #1117.
..S $P(^AUPNPAT(DFN,11),U,17)=CC
..;---> Set the "CURRENT COMMUNITY" Field #1118 (text).
..S $P(^AUPNPAT(DFN,11),U,18)=$P(^AUTTCOM(CC,0),U)
..S TOTAL=TOTAL+1
.;
.;---> If Previous Comm failed, get text of Community from piece 18.
.S X=$P(^AUPNPAT(DFN,11),U,18)
.Q:X=""
.;
.;---> If text of piece 18 exists in Community file, get IEN and
.;---> set patient's piece 17=IEN in Community File.
.D:$D(^AUTTCOM("B",X))
..S Y=$O(^AUTTCOM("B",X,0))
..;---> Quit if there are other instances of this name.
..Q:$O(AUTTCOM("B",X,Y))
..;---> Quit if the pointer is bad.
..Q:'$D(^AUTTCOM(+Y,0))
..S $P(^AUPNPAT(DFN,11),U,17)=Y
..S TOTAL=TOTAL+1
;
W !!?5,"Total changed: ",TOTAL,!?5,"Done.",!
Q
;
;
;----------
BADINACT ; EP
;---> Correct any bad Inactive Dates, that were 1 or 0 from earLier
;---> version.
D ^XBKVAR
N M,N,P
S M=0,P=0
S N=0
F S N=$O(^BIP(N)) Q:'N D
.I $P(^BIP(N,0),"^",8)=1 S $P(^(0),U,8)=2990507 S M=M+1 Q
.I $P(^BIP(N,0),"^",8)=0 S $P(^(0),U,8)="" S P=P+1 Q
;
W !,"BAD DATES: ",M
W !,"ZERO ACTIVE: ",P
Q
;
;
;----------
LOTNUM ;EP
;---> Inactivate all Lot Numbers.
D ^XBKVAR
N N S N=0
F S N=$O(^AUTTIML(N)) Q:'N D
.Q:'$D(^AUTTIML(N,0))
.;---> Do not Inactivate if Exp Date is later than Today.
.Q:($P(^AUTTIML(N,0),"^",9)>$G(DT))
.;---> Inactivate this Lot Number.
.S $P(^AUTTIML(N,0),"^",3)=1
W !!,"All Lot Numbers have been Inactivated.",!
Q
;
;
RELCONT ;EP
;---> Update Flu Related Contraindications.
;
D ^XBKVAR
N N,Y S N=0
;---> Flu CVX Codes, related contraindications.
S Y="15,16,88,111,123,125,126,127,128,135,140,141,144,149,150,151,153,155,158,161,166,168,171,185"
F S N=$O(^BITN(N)) Q:'N D
.;---> Quit if this is not in the FLU Vaccine Group.
.Q:($P(^BITN(N,0),U,9)'=10)
.W !!,$P(^BITN(N,0),U,3)," ",$P(^BITN(N,0),U,12)
.S $P(^BITN(N,0),U,12)=Y
;
Q
;
;
;----------
NULLACT ;EP
;---> Activate all Lot Numbers that have a Status=null.
;---> Call by postinit for Imm v8.5.
;
D ^XBKVAR
W !!?5,"Checking Lot Numbers for null Status..."
N M,N S M=0,N=0
F S N=$O(^AUTTIML(N)) Q:'N D
.Q:'$D(^AUTTIML(N,0))
.;---> Quit if this lot number has a Status .
.Q:($P(^AUTTIML(N,0),"^",3)'="")
.;---> Okay, Status must be null, so set it to Active.
.S $P(^AUTTIML(N,0),"^",3)=0,M=M+1
W !!?5,"Done. ",M," Lot Numbers have been fixed." D DIRZ^BIUTL3()
Q
BIUTLFIX ;IHS/CMI/MWR - UTIL: FIX STUFF.; AUG 10, 2010
+1 ;;8.5;IMMUNIZATION;**14**;AUG 01,2017
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; UTILITY: FIXES: LISTMAN HIDDEN MENUS.
+4 ;; PATCH 1: UPDATE VACCINE TABLE: ADD "INFLUENZA, 1203" CVX=123
+5 ;; PATCH 5: Back-populate SNOMED Codes to all Contraindications. SNOMED+0
+6 ;; PATCH 14: Update NOTE at BUILD+5 and date at BUILD+29
+7 ;; New rtn BITN3 to accommodate larger Vaccine Table BUILD+81
+8 ;
+9 ;
+10 ;----------
BUILD ;EP
+1 ;---> STEPS TO ADD NEW VACCINE TO VACCINE TABLE/IMMUNIZATION FILE:
+2 ;
+3 ;---> 1) Use Fileman to add new vaccine to the BI IMMUNIZATION TABLE
+4 ;---> HL7/CVX STANDARD File #9002084.94.
+5 ;---> NOTE: ^BITN nodes must have a 1 node (e.g., ^BITN(IEN,1)),
+6 ;---> easily done by populating the FULL NAME 1.14 field per CDC.
+7 ;
+8 ;---> 2) Execute line listed below to update ^BITN routine.
+9 ;---> (At programmer prompt, D BUILD^BIUTLFIX ZR X BIX0.)
+10 ;
+11 ;---> 3) Load BITN2 into an editor and trim the entire BITN routine
+12 ;---> that gets tacked onto the end of BITN2 during compilation.
+13 ;
+14 ;---> 4) Restandardize the Vaccine Table D RESTAND^BIRESTD().
+15 ;---> (Or under Manager Menu do MGR-->RES.)
+16 ;
+17 ;---> Build routine ^BITN.
+18 ;---> Not called by any option or User action. Used by package
+19 ;---> programmer to create routine BITN, which in turn is used
+20 ;---> to build ^BITN global during installation.
+21 ;---> To use: At programmer prompt, D BUILD^BIUTLFIX ZR X BIX0.
+22 ;
+23 DO SETVARS^BIUTL5
+24 KILL BIXDT
SET BIXDT=$$TXDT^BIUTL5(DT)
+25 SET BIX0="N I F I=1:1 Q:'$D(@(""BIX""_I)) X @(""BIX""_I)"
+26 ;
+27 ;---> build first routine for nodes <200.
+28 SET BIX1="ZI ""BITN ;IHS/CMI/MWR - BUILD ^BITN GLOBAL."""
+29 SET BIX2="ZI "" ;;8.5;IMMUNIZATION;**14**;AUG 01,2017"""
+30 SET BIX3="ZI "" ;;* MICHAEL REMILLARD, DDS"
+31 SET BIX3=BIX3_" * CIMARRON MEDICAL INFORMATICS, FOR IHS *"""
+32 SET BIX4="ZI "" ;; UTILITY: BUILD STANDARD ^BITN GLOBAL."""
+33 SET BIX5="ZI "" ;"","" ;"","" ;----------"",""START ;EP"""
+34 SET BIX6="ZI "" D KGBL^BIUTL8(""""^BITN"""")"""
+35 SET BIX7="ZI "" S ^BITN(0)=""""BI IMMUNIZATION TABLE HL7 STANDARD"
+36 SET BIX7=BIX7_"^9002084.94I"""""""
+37 ;
+38 SET BIX8="ZI "" N I,X,Y,Z"""
+39 SET BIX9="ZI "" F I=1:2 S X=$T(@""""TABLE""""+I) Q:X'["""";;"""" D"""
+40 SET BIX10="ZI "" .S Y=$P(X,"""";;"""",2),Z=$P(X,"""";;"""",3)"""
+41 SET BIX11="ZI "" .S ^BITN(Y,0)=Z"" ZI "" .S X=$T(@""""TABLE""""+(I+1))"
+42 SET BIX11=BIX11_",Z=$P(X,"""";;"""",3),^BITN(Y,1)=Z"","" ;"""
+43 ;
+44 ;---> Next node for future inserts.
+45 SET BIX12=""
+46 ;
+47 SET BIX13="ZI "" F I=1:2 S X=$T(@""""TABLE""""+I^BITN2) Q:X'["""";;"""" D"""
+48 SET BIX14="ZI "" .S Y=$P(X,"""";;"""",2),Z=$P(X,"""";;"""",3)"""
+49 SET BIX15="ZI "" .S ^BITN(Y,0)=Z"" ZI "" .S X=$T(@""""TABLE""""+(I+1)^BITN2)"
+50 SET BIX15=BIX15_",Z=$P(X,"""";;"""",3),^BITN(Y,1)=Z"","" ;"""
+51 ;
+52 SET BIX16="ZI "" F I=1:2 S X=$T(@""""TABLE""""+I^BITN3) Q:X'["""";;"""" D"""
+53 SET BIX17="ZI "" .S Y=$P(X,"""";;"""",2),Z=$P(X,"""";;"""",3)"""
+54 SET BIX18="ZI "" .S ^BITN(Y,0)=Z"" ZI "" .S X=$T(@""""TABLE""""+(I+1)^BITN3)"
+55 SET BIX18=BIX18_",Z=$P(X,"""";;"""",3),^BITN(Y,1)=Z"","" ;"""
+56 ;
+57 SET BIX19="ZI "" N DIK S DIK=""""^BITN("""" D IXALL^DIK"""
+58 SET BIX20="ZI "" Q"","" ;"","" ;"","" ;----------"",""TABLE ; EP"""
+59 SET BIX21="N N S N=0 F S N=$O(^BITN(N)) Q:'N Q:(N>189) "
+60 ;S BIX18="N N S N=0 F S N=$O(^AUTTIMM(N)) Q:'N "
+61 SET BIX21=BIX21_"ZI "" ;;""_N_"";;""_^BITN(N,0)"
+62 SET BIX21=BIX21_" ZI "" ;;""_N_""a;;""_^BITN(N,1)"
+63 SET BIX22="ZS BITN ZR "
+64 ;
+65 ;---> Now build second routine for nodes >189.
+66 SET BIX23="ZI ""BITN2 ;IHS/CMI/MWR - BUILD ^BITN GLOBAL SECOND PART."""
+67 SET BIX24="ZI "" ;;8.5;IMMUNIZATION;**14**;AUG 01,2017"""
+68 SET BIX25="ZI "" ;;* MICHAEL REMILLARD, DDS"
+69 SET BIX25=BIX25_" * CIMARRON MEDICAL INFORMATICS, FOR IHS *"""
+70 SET BIX26="ZI "" ;; UTILITY: BUILD STANDARD ^BITN GLOBAL."""
+71 SET BIX27="ZI "" ;"","" ;"","" ;----------"",""TABLE ; EP"""
+72 ;S BIX25="N N S N=199 F S N=$O(^BITN(N)) Q:'N "
+73 SET BIX28="N N S N=189 F S N=$O(^BITN(N)) Q:'N Q:(N>259) "
+74 SET BIX28=BIX28_"ZI "" ;;""_N_"";;""_^BITN(N,0)"
+75 SET BIX28=BIX28_" ZI "" ;;""_N_""a;;""_^BITN(N,1)"
+76 SET BIX29="ZI "" Q"""
+77 ;S BIX27="ZS BITN2"
+78 ;S BIX28="W !,""DONE. Load and trim BITN2"""
+79 SET BIX30="ZS BITN2 ZR "
+80 ;
+81 ;********** PATCH 14, v8.5, AUG 01,2017, IHS/CMI/MWR
+82 ;---> New rtn BITN3 to accommodate larger Vaccine Table.
+83 ;---> Now build third routine for nodes >260.
+84 SET BIX31="ZI ""BITN3 ;IHS/CMI/MWR - BUILD ^BITN GLOBAL THIRD PART."""
+85 SET BIX32="ZI "" ;;8.5;IMMUNIZATION;**14**;AUG 01,2017"""
+86 SET BIX33="ZI "" ;;* MICHAEL REMILLARD, DDS"
+87 SET BIX33=BIX33_" * CIMARRON MEDICAL INFORMATICS, FOR IHS *"""
+88 SET BIX34="ZI "" ;; UTILITY: BUILD STANDARD ^BITN GLOBAL."""
+89 SET BIX35="ZI "" ;"","" ;"","" ;----------"",""TABLE ; EP"""
+90 SET BIX36="N N S N=259 F S N=$O(^BITN(N)) Q:'N "
+91 SET BIX36=BIX36_"ZI "" ;;""_N_"";;""_^BITN(N,0)"
+92 SET BIX36=BIX36_" ZI "" ;;""_N_""a;;""_^BITN(N,1)"
+93 SET BIX37="ZI "" Q"""
+94 SET BIX38="ZS BITN3 ZR "
+95 SET BIX39="W !,""DONE. Load and trim BITN2 and BITN3"""
+96 QUIT
+97 ;
+98 ;
+99 ;********** PATCH 5, v8.5, JUL 01,2013, IHS/CMI/MWR
SNOMED ;PEP - Back-populate SNOMED Codes to all Contraindications.
+1 ;
+2 NEW BIIEN
SET BIIEN=0
FOR
SET BIIEN=$ORDER(^BIPC(BIIEN))
IF 'BIIEN
QUIT
Begin DoDot:1
+3 IF '$DATA(^BIPC(BIIEN,0))
QUIT
+4 NEW BICRIEN,BIVIEN,BIY
+5 SET BIY=^BIPC(BIIEN,0)
+6 ;Vaccine IEN.
SET BIVIEN=$PIECE(BIY,U,2)
+7 ;Contraindication Reason IEN.
SET BICRIEN=$PIECE(BIY,U,3)
+8 NEW I,X,Y
+9 ;---> Get string of Vaccine Component IEN's.
+10 SET X=$$VCOMPS^BIUTL2(BIVIEN)
+11 ;---> If no components process the vaccine itself.
+12 IF ('+X)
SET X=BIVIEN
+13 ;
+14 FOR I=1:1:6
SET Y=$PIECE(X,";",I)
IF 'Y
QUIT
Begin DoDot:2
+15 ;---> Get Vaccine Group IEN of this vaccine.
+16 NEW BIVGRP
SET BIVGRP=$$IMMVG^BIUTL2(Y)
+17 ;---> Quit if Vaccine Group is Other, Skin Test, or Combo.
+18 IF ((BIVGRP=12)!(BIVGRP=13)!(BIVGRP=14)!(BIVGRP<1))
QUIT
+19 ;---> Call Lori's Magic Mapper to get SNOMED Code.
+20 DO SNOMED^BIRPC4(BIVGRP,BICRIEN,BIIEN)
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;**********
+23 ;
+24 ;
+25 ;----------
+1 ;---> Fix/update Listmanager hidden menus.
+2 ;---> This will go through all of the BI PROTOCOLS and update
+3 ;---> any hidden menus.
+4 ;
+5 DO ^XBKVAR
+6 DO LISTQUIT
+7 NEW N
SET N="BI"
+8 FOR
SET N=$ORDER(^ORD(101,"B",N))
IF N=""
QUIT
IF N]"BIZZZ"
QUIT
Begin DoDot:1
+9 IF N'["HIDDEN"
QUIT
+10 NEW BIIEN
SET BIIEN=$ORDER(^ORD(101,"B",N,0))
+11 IF BIIEN
DO FIX(BIIEN)
End DoDot:1
+12 QUIT
+13 ;
+14 ;
+15 ;----------
FIX(BIIEN) ;EP
+1 IF 'BIIEN
QUIT
IF '$DATA(^ORD(101,+BIIEN,0))
QUIT
+2 SET XQORM=+BIIEN_";ORD(101,"
+3 DO XREF^XQORM
+4 QUIT
+5 ;
+6 ;
+7 ;----------
LISTQUIT ;EP
+1 ;---> Set Quit synonym to "Q" on VALM HIDDEN ACTIONS Protocol.
+2 ;---> Get IEN of VALM HIDDEN ACTIONS Protocol.
+3 NEW BIN
SET BIN=$ORDER(^ORD(101,"B","VALM HIDDEN ACTIONS",0))
+4 IF 'BIN
QUIT
+5 IF $PIECE(^ORD(101,BIN,0),U)'="VALM HIDDEN ACTIONS"
QUIT
+6 ;
+7 ;---> Find "VALM QUIT" Item.
+8 NEW N
SET N=0
+9 FOR
SET N=$ORDER(^ORD(101,BIN,10,N))
IF 'N
QUIT
Begin DoDot:1
+10 NEW X,Y
+11 SET X=$PIECE(^ORD(101,BIN,10,N,0),U)
+12 SET Y=$PIECE($GET(^ORD(101,X,0)),U)
+13 IF Y'="VALM QUIT"
QUIT
+14 SET $PIECE(^ORD(101,BIN,10,N,0),U,2)="Q"
End DoDot:1
+15 DO FIX(BIN)
+16 QUIT
+17 ;
+18 ;
+19 ;----------
ONE ;EP
+1 ;---> Individual Hidden Menu lookup.
+2 WRITE !!,"Select the Protocol you wish to fix.",!
+3 DO DIC^BIFMAN(101,"QEMA",.Y)
+4 IF Y<0
QUIT
+5 DO FIX(+Y)
+6 QUIT
+7 ;
+8 ;
+9 ;----------
BADPATS ;EP
+1 ;---> Look for BI PATIENTS with no data in ^BIP(BIDFN,0) node.
+2 ;
+3 SET N=0
+4 FOR
SET N=$ORDER(^BIP(N))
IF 'N
QUIT
Begin DoDot:1
+5 IF '$PIECE(^BIP(N,0),"^")
WRITE !,N,": ",^(0)
End DoDot:1
+6 QUIT
+7 ;
+8 ;
+9 ;----------
ACTIVE ;EP
+1 ;---> Fix patients whose "Date Inactive" was erroneously converted.
+2 ;---> 1=Active, 0=Inactive.
+3 ;
+4 NEW BITOTN,BITOTY
+5 SET N=0
+6 SET BITOTN=0
SET BITOTY=0
+7 FOR
SET N=$ORDER(^BIP(N))
IF 'N
QUIT
Begin DoDot:1
+8 IF $PIECE(^BIP(N,0),"^",8)=0
SET $PIECE(^(0),U,8)=DT
SET BITOTN=BITOTN+1
QUIT
+9 IF $PIECE(^BIP(N,0),"^",8)=1
SET $PIECE(^(0),U,8)=""
SET BITOTY=BITOTY+1
End DoDot:1
+10 WRITE !,"NO : ",BITOTN
+11 WRITE !,"YES: ",BITOTY
+12 QUIT
+13 ;
+14 ;
+15 ;----------
CHGPTR(BICHG) ;EP
+1 ;---> Change all records with one vaccine pointer to a different one.
+2 ;---> Parameters:
+3 ; 1 - BICHG (opt) IF BICHG=1 then change entries from 214 to 235.
+4 ;
+5 DO SETVARS^BIUTL5
+6 DO KGBL^BIUTL8("^MIKE")
SET ^MIKE(0)=^AUPNVIMM(0)
+7 NEW BICOUNT,BIECOUNT,BIN
SET BIN=0
SET BICOUNT=0
SET BIECOUNT=0
+8 FOR
SET BIN=$ORDER(^AUPNVIMM(BIN))
IF 'BIN
QUIT
Begin DoDot:1
+9 NEW BIERR
SET BIERR=0
+10 IF ($PIECE(^AUPNVIMM(BIN,0),U)'=214)
QUIT
+11 SET BICOUNT=BICOUNT+1
+12 IF ('$GET(BICHG))
QUIT
+13 SET ^MIKE(BIN,0)=^AUPNVIMM(BIN,0)
+14 ;
+15 ;---> Change .01 pointer to VAccine Table.
+16 NEW BIFLD
SET BIFLD(.01)=235
+17 DO FDIE^BIFMAN(9000010.11,BIN,.BIFLD,.BIERR)
+18 IF BIERR=1
SET BIECOUNT=BIECOUNT+1
SET ^MIKE("ERR",N)=""
QUIT
End DoDot:1
+19 ;
+20 WRITE !!,"COUNT: ",BICOUNT
+21 WRITE !,"ERRORS: ",BIECOUNT
+22 QUIT
+23 ;
+24 ;
+25 ;----------
CURCOM ;EP
+1 ;---> Utility to update Patients' Curren Community pointer, piece 17,
+2 ;---> based on text of Community in piece 18 of ^AUPNPAT(DFN,11).
+3 ;
+4 NEW DFN,TOTAL
+5 SET DFN=0
SET TOTAL=0
SET U="^"
+6 FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF 'DFN
QUIT
Begin DoDot:1
+7 NEW X,Y
+8 IF '$DATA(^AUPNPAT(DFN,11))
QUIT
+9 ;
+10 ;---> Quit if piece 17 is already set.
+11 IF $PIECE(^AUPNPAT(DFN,11),U,17)
QUIT
+12 ;
+13 ;---> First try to get Current Community pointer from the last
+14 ;---> "Community of Residence" Subfield of "Previous Community"
+15 ;---> (Field .03 of the last/latest 51 subnode).
+16 NEW CC,N
SET CC=""
SET N=0
+17 FOR
SET N=$ORDER(^AUPNPAT(DFN,51,N))
IF 'N
QUIT
Begin DoDot:2
+18 SET CC=$PIECE($GET(^AUPNPAT(DFN,51,N,0)),U,3)
End DoDot:2
+19 ;
+20 ;---> If the last Previous Community is a good pointer, use it & quit.
+21 IF CC
IF $DATA(^AUTTCOM(CC,0))
Begin DoDot:2
+22 ;---> Set the "CURRENT RESIDENCE PTR" Field #1117.
+23 SET $PIECE(^AUPNPAT(DFN,11),U,17)=CC
+24 ;---> Set the "CURRENT COMMUNITY" Field #1118 (text).
+25 SET $PIECE(^AUPNPAT(DFN,11),U,18)=$PIECE(^AUTTCOM(CC,0),U)
+26 SET TOTAL=TOTAL+1
End DoDot:2
QUIT
+27 ;
+28 ;---> If Previous Comm failed, get text of Community from piece 18.
+29 SET X=$PIECE(^AUPNPAT(DFN,11),U,18)
+30 IF X=""
QUIT
+31 ;
+32 ;---> If text of piece 18 exists in Community file, get IEN and
+33 ;---> set patient's piece 17=IEN in Community File.
+34 IF $DATA(^AUTTCOM("B",X))
Begin DoDot:2
+35 SET Y=$ORDER(^AUTTCOM("B",X,0))
+36 ;---> Quit if there are other instances of this name.
+37 IF $ORDER(AUTTCOM("B",X,Y))
QUIT
+38 ;---> Quit if the pointer is bad.
+39 IF '$DATA(^AUTTCOM(+Y,0))
QUIT
+40 SET $PIECE(^AUPNPAT(DFN,11),U,17)=Y
+41 SET TOTAL=TOTAL+1
End DoDot:2
End DoDot:1
+42 ;
+43 WRITE !!?5,"Total changed: ",TOTAL,!?5,"Done.",!
+44 QUIT
+45 ;
+46 ;
+47 ;----------
BADINACT ; EP
+1 ;---> Correct any bad Inactive Dates, that were 1 or 0 from earLier
+2 ;---> version.
+3 DO ^XBKVAR
+4 NEW M,N,P
+5 SET M=0
SET P=0
+6 SET N=0
+7 FOR
SET N=$ORDER(^BIP(N))
IF 'N
QUIT
Begin DoDot:1
+8 IF $PIECE(^BIP(N,0),"^",8)=1
SET $PIECE(^(0),U,8)=2990507
SET M=M+1
QUIT
+9 IF $PIECE(^BIP(N,0),"^",8)=0
SET $PIECE(^(0),U,8)=""
SET P=P+1
QUIT
End DoDot:1
+10 ;
+11 WRITE !,"BAD DATES: ",M
+12 WRITE !,"ZERO ACTIVE: ",P
+13 QUIT
+14 ;
+15 ;
+16 ;----------
LOTNUM ;EP
+1 ;---> Inactivate all Lot Numbers.
+2 DO ^XBKVAR
+3 NEW N
SET N=0
+4 FOR
SET N=$ORDER(^AUTTIML(N))
IF 'N
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUTTIML(N,0))
QUIT
+6 ;---> Do not Inactivate if Exp Date is later than Today.
+7 IF ($PIECE(^AUTTIML(N,0),"^",9)>$GET(DT))
QUIT
+8 ;---> Inactivate this Lot Number.
+9 SET $PIECE(^AUTTIML(N,0),"^",3)=1
End DoDot:1
+10 WRITE !!,"All Lot Numbers have been Inactivated.",!
+11 QUIT
+12 ;
+13 ;
RELCONT ;EP
+1 ;---> Update Flu Related Contraindications.
+2 ;
+3 DO ^XBKVAR
+4 NEW N,Y
SET N=0
+5 ;---> Flu CVX Codes, related contraindications.
+6 SET Y="15,16,88,111,123,125,126,127,128,135,140,141,144,149,150,151,153,155,158,161,166,168,171,185"
+7 FOR
SET N=$ORDER(^BITN(N))
IF 'N
QUIT
Begin DoDot:1
+8 ;---> Quit if this is not in the FLU Vaccine Group.
+9 IF ($PIECE(^BITN(N,0),U,9)'=10)
QUIT
+10 WRITE !!,$PIECE(^BITN(N,0),U,3)," ",$PIECE(^BITN(N,0),U,12)
+11 SET $PIECE(^BITN(N,0),U,12)=Y
End DoDot:1
+12 ;
+13 QUIT
+14 ;
+15 ;
+16 ;----------
NULLACT ;EP
+1 ;---> Activate all Lot Numbers that have a Status=null.
+2 ;---> Call by postinit for Imm v8.5.
+3 ;
+4 DO ^XBKVAR
+5 WRITE !!?5,"Checking Lot Numbers for null Status..."
+6 NEW M,N
SET M=0
SET N=0
+7 FOR
SET N=$ORDER(^AUTTIML(N))
IF 'N
QUIT
Begin DoDot:1
+8 IF '$DATA(^AUTTIML(N,0))
QUIT
+9 ;---> Quit if this lot number has a Status .
+10 IF ($PIECE(^AUTTIML(N,0),"^",3)'="")
QUIT
+11 ;---> Okay, Status must be null, so set it to Active.
+12 SET $PIECE(^AUTTIML(N,0),"^",3)=0
SET M=M+1
End DoDot:1
+13 WRITE !!?5,"Done. ",M," Lot Numbers have been fixed."
DO DIRZ^BIUTL3()
+14 QUIT
