Routine: BIUTLFIX

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

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

 ;**********

 ;----------

LISTMENU ;EP

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

 ;----------

FIX(BIIEN) ;EP

 Q:'BIIEN  Q:'$D(^ORD(101,+BIIEN,0))

 S XQORM=+BIIEN_";ORD(101,"

 D XREF^XQORM

 ;----------

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)

 ;----------

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)

 ;----------

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)

 ;----------

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

 ;----------

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

 ;----------

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.",!

 ;----------

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

 ;----------

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.",!

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

 ;----------

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()

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

LISTMENU  ;EP

 +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

BIUTLFIX.m