BKM11PST ;APTIV/HC/ALA-Ver 1.1 Post Install ; 10 Jan 2008 11:30 AM
;;2.0;HIV MANAGEMENT SYSTEM;;May 29, 2009
;
;**Program Description**
; This is the post-installation program to set up values for the
; HIV Management System
;
EN ; Entry Point
;
; Never before installed
I $O(^BKM(90450,0))="" D
. D INIT
;
I '$$PATCH^XPDUTL("BKM*1.0*1") D PTCH1
I '$$PATCH^XPDUTL("BKM*1.0*2") D PTCH2
;
Q
;
PRE ; Preinstall
NEW DA,DIK
S DIK="^BKM(90454,"
S DA=0
F S DA=$O(^BKM(90454,DA)) Q:'DA D ^DIK
;
S DA=1,DIK="^BKM(90456," D ^DIK
;
NEW DA,DIK
S DIK="^BKM(90450,",DA=1 D ^DIK
Q
;
INIT ; Set up the HIV registry entry
NEW X,DIC,DLAYGO,REGISTER,DA,DR,DIE,Y
S X="HMS REGISTER",DIC(0)="LMNZ",DLAYGO=90450,DIC="^BKM(90450,"
D ^DIC
S (REGISTER,DA)=+Y
S DR=".02////HMS;12////1;12.5////1;19////0",DIE=DIC D ^DIE
;
; Add the intro text for autopopulate
NEW BI,LM K ^TMP($J,"BKMTXT")
F BI=1:1:18 S LM=$T(TXT+BI) Q:LM=" Q" S ^TMP($J,"BKMTXT",BI,0)=$P(LM,";;",2)
D WP^DIE(90450,REGISTER,50,"","^TMP($J,""BKMTXT"")")
K ^TMP($J,"BKMTXT")
;
QM ; Set up QMAN entries
NEW X,DIC,DLAYGO,DA,DR,DIE,LINK,Y,TERM
S X="PATIENT;IMM",DIC(0)="LMNZ",DLAYGO=9009071,DIC="^AMQQ(1,"
D ^DIC
S (DA,LINK)=+Y
S BKMUPD(9009071,LINK_",",1)=9999999.14,BKMUPD(9009071,LINK_",",2)=9000010.11
S BKMUPD(9009071,LINK_",",3)=".01",BKMUPD(9009071,LINK_",",4)=10,BKMUPD(9009071,LINK_",",7)=1
D FILE^DIE("","BKMUPD")
K BKMUPD,X,DA,DIC,DIE,DLAYGO,Y
;
S X="HMS IMMUNIZATION",DIC(0)="LMNZ",DLAYGO=9009075,DIC="^AMQQ(5,"
D ^DIC
S (DA,TERM)=+Y
S BKMUPD(9009075,TERM_",",1)="P",BKMUPD(9009075,TERM_",",3)=1,BKMUPD(9009075,TERM_",",4)=LINK
S BKMUPD(9009075,TERM_",",13)=3,BKMUPD(9009075,TERM_",",14)="IMMUNIZATION"
S BKMUPD(9009075,TERM_",",18)="AUTTIMM(",BKMUPD(9009075,TERM_",",19)="C"
S BKMUPD(9009075,TERM_",",20)="M"
D FILE^DIE("","BKMUPD")
K BKMUPD,X,DA,DIC,DIE,DLAYGO,Y
;
S X="HMS IMMUNIZATIONS",DA(1)=TERM,DIC(0)="LMNZ",DIC="^AMQQ(5,"_DA(1)_",1,",DLAYGO=9009075.01
D ^DIC
;
NEW X,DIC,DLAYGO,DA,DR,DIE,LINK,Y,TERM
S X="PATIENT;LOINC",DIC(0)="LMNZ",DLAYGO=9009071,DIC="^AMQQ(1,"
D ^DIC
S (DA,LINK)=+Y
S BKMUPD(9009071,LINK_",",1)=95.3,BKMUPD(9009071,LINK_",",2)=9000010.09
S BKMUPD(9009071,LINK_",",3)=".01",BKMUPD(9009071,LINK_",",4)=10,BKMUPD(9009071,LINK_",",7)=1
D FILE^DIE("","BKMUPD")
K BKMUPD,X,DA,DIC,DIE,DLAYGO,Y
;
S X="LOINC",DIC(0)="LMNZ",DLAYGO=9009075,DIC="^AMQQ(5,"
D ^DIC
S (DA,TERM)=+Y
S BKMUPD(9009075,TERM_",",1)="P",BKMUPD(9009075,TERM_",",3)=4,BKMUPD(9009075,TERM_",",4)=LINK
S BKMUPD(9009075,TERM_",",13)=3,BKMUPD(9009075,TERM_",",14)="LOINC"
S BKMUPD(9009075,TERM_",",18)="LAB(95.3,",BKMUPD(9009075,TERM_",",19)="C"
S BKMUPD(9009075,TERM_",",20)="M"
D FILE^DIE("","BKMUPD")
K BKMUPD,X,DA,DIC,DIE,DLAYGO,Y
;
S X="HMS IMMUNIZATIONS",DA(1)=TERM,DIC(0)="LMNZ",DIC="^AMQQ(5,"_DA(1)_",1,",DLAYGO=9009075.01
D ^DIC
;
S MOK=$$ADD^XPDMENU("BKMV REPORTS","BGPMENU","GPRA",7)
S MOK=$$ADD^XPDMENU("BKMV OTHER RPMS","LR IHS MENU")
S MOK=$$ADD^XPDMENU("BKMV OTHER RPMS","PSO USER1")
S MOK=$$ADD^XPDMENU("BKMV OTHER RPMS","GMRAMGR")
S MOK=$$ADD^XPDMENU("BKMV OTHER RPMS","AGMENU")
S MOK=$$ADD^XPDMENU("BKMV OTHER RPMS","BMCMENU")
S MOK=$$ADD^XPDMENU("BKMV OTHER RPMS","AMQQMENU")
S MOK=$$ADD^XPDMENU("BKMV OTHER RPMS","BSDMENU")
S MOK=$$ADD^XPDMENU("XUCORE","BKMVMENU","HMS",7)
K MOK
;
BLR ;
; Check the IHS LAB CPT CODE File for bad pointers
NEW CT,BLN,LBN,XMY,XMZ
K ^TMP("BQIMAIL",$J)
S BLN=0,CT=0
F S BLN=$O(^BLRCPT(BLN)) Q:'BLN D
. S LBN=$P($G(^BLRCPT(BLN,1)),U,1)
. Q:LBN=""
. Q:$G(^LAB(60,LBN,0))'=""
. S CT=CT+1,^TMP("BQIMAIL",$J,CT,0)="The "_$P(^BLRCPT(BLN,0),U,1)_" record in the IHS LAB CPT CODE File #9009021 PANEL/TEST pointer does not exist in the LAB TEST File #60."
I $D(^TMP("BQIMAIL",$J))>0 D
. S CT=CT+1,^TMP("BQIMAIL",$J,CT,0)=" "
. S CT=CT+1,^TMP("BQIMAIL",$J,CT,0)="Go to option BLR EDIT IHS LAB CPT FILE to correct these records."
. S XMSUB="iCare Install Problem"
. S XMTEXT="^TMP(""BQIMAIL"",$J,"
. I $G(DUZ)'="" S XMDUZ=DUZ,XMY(DUZ)=""
. I $G(DUZ)="" S XMDUZ="iCare Install"
. S XMY(DUZ)=""
. NEW BDUZ
. S BDUZ="" F S BDUZ=$O(^XUSEC("LRLIASON",BDUZ)) Q:BDUZ="" D
.. I $P($G(^VA(200,BDUZ,0)),U,11)'="" Q
.. S XMY(BDUZ)=""
. I '$D(XMY) S XMY(.5)=""
. D ^XMD
;
LTAX ; Add Lab Taxonomies to ^ATXLAB
NEW X,DIC,DLAYGO,DA,DR,DIE,Y,LTAX
S DIC="^ATXLAB(",DIC(0)="L",DLAYGO=9002228
; Loop through the Taxonomies as stored in routine BKMVTAX4.
D LDLAB^BKMVTAX4(.LTAX)
F BJ=1:1 Q:'$D(LTAX(BJ)) S X=LTAX(BJ) D
. I $D(^ATXLAB("B",X)) Q ; Skip pre-existing Lab taxonomies
. D ^DIC S DA=+Y
. I DA<1 Q
. S BKTXUP(9002228,DA_",",.02)=$P(X," ",2,999)
. S BKTXUP(9002228,DA_",",.05)=DUZ
. S BKTXUP(9002228,DA_",",.06)=DT
. S BKTXUP(9002228,DA_",",.09)=60
. D FILE^DIE("I","BKTXUP")
. S BKTXUP(9002228,DA_",",.08)="B"
. D FILE^DIE("E","BKTXUP")
;
K DA,BJ,BKTXUP
;
TAX ; Set up the taxonomies
D ^BKMTX
D ^BKMATX
D ^BKMBTX
D ^BKMCTX
D ^BKMDTX
;
USR ; Set up the Case File Manager
;D CFM^BKMVB1
K IEN,HIVIEN,GETDFN,BKMUSER,OCCUP,USER,X,Y
;
; PRXM/HC/BHS - 05/10/2006 - Convert UN code to UNR per IHS
UNR ; Check the HMS CANDIDATE File for Status (.03) = "UN" and
; if found convert to "UNR"
NEW DA,DIE,DR,STATUS
S DA=0
F S DA=$O(^BKM(90451.2,DA)) Q:'DA D
. S STATUS=$$GET1^DIQ(90451.2,DA,".03","I")
. ; Only convert UN code to UNR
. Q:STATUS'="UN"
. S DIE="^BKM(90451.2,",DR=".03///UNR"
. D ^DIE
;
Q
;
TXT ; Text to be stored
;;The autopopulate function will search your RPMS database to identify
;;patient candidates for your site's HMS Register. You can review your
;;candidate list (REV option) after the autopopulate and move selected
;;patients to the Register.
;;
;;HMS uses the following logic to identify patients as candidates:
;; 1. at least one POV or Problem List diagnosis of HIV ever; or
;; 2. a positive result on an HIV test; or
;; 3. at least 2 of any antiretroviral medications (NRTI, NNRTI, PI or
;; FI medications)
;;
;;See the User Manual for complete, detailed definitions and related
;;taxonomies.
;;
;;Checking for Taxonomies . . .
;;
;;In order for the HMS autopopulate function to find all necessary data,
;;several taxonomies must be established.
Q
;
PTCH1 ; Patch 1 postinstall fixes
; Check candidate list and remove entries
NEW DFN,MED,DFLG,STAT,TAX
S DFN=0
F S DFN=$O(^BKM(90451.2,DFN)) Q:'DFN D
. S STAT=$P(^BKM(90451.2,DFN,0),U,3)
. I STAT="NOT"!(STAT="REM") Q
. S MED=0,DFLG=0
. F S MED=$O(^BKM(90451.2,DFN,3,MED)) Q:'MED D Q:DFLG
.. S TAX=$P(^BKM(90451.2,DFN,3,MED,0),U,3)
.. I TAX="BKMV EI MEDS"!(TAX="BKMV NNRTI MEDS")!(TAX="BKMV NRTI MEDS")!(TAX="BKMV PI MEDS") S DFLG=1 Q
. I DFLG D
.. NEW DA,DIK
.. S DA=DFN,DIK="^BKM(90451.2," D ^DIK
;
TX ; Check taxonomies
NEW TAX,DIC,X,TDA,Y
S DIC="^ATXAX(",DIC(0)="Z"
S TAX="BKMV EI MEDS",X=TAX D ^DIC S TDA=+Y
I TDA'=-1 D
. NEW DA,VALUE
. S DA(1)=TDA,DA=0
. F S DA=$O(^ATXAX(TDA,21,DA)) Q:'DA D
.. S VALUE=$P(^ATXAX(TDA,21,DA,0),U,1)
.. I VALUE=5201!(VALUE=83677)!(VALUE=84151) D
... S DIK="^ATXAX("_DA(1)_",21," D ^DIK
;
NEW TAX,DIC,X,TDA,Y
S DIC="^ATXAX(",DIC(0)="Z"
S TAX="BKMV NNRTI MEDS",X=TAX D ^DIC S TDA=+Y
I TDA'=-1 D
. NEW DA,VALUE
. S DA(1)=TDA,DA=0
. F S DA=$O(^ATXAX(TDA,21,DA)) Q:'DA D
.. S VALUE=$P(^ATXAX(TDA,21,DA,0),U,1)
.. I VALUE=84282!(VALUE=84317)!(VALUE=84318) D
... S DIK="^ATXAX("_DA(1)_",21," D ^DIK
;
NEW TAX,DIC,X,TDA,Y
S DIC="^ATXAX(",DIC(0)="Z"
S TAX="BKMV NRTI MEDS",X=TAX D ^DIC S TDA=+Y
I TDA'=-1 D
. NEW DA,VALUE
. S DA(1)=TDA,DA=0
. F S DA=$O(^ATXAX(TDA,21,DA)) Q:'DA D
.. S VALUE=$P(^ATXAX(TDA,21,DA,0),U,1)
.. I VALUE=83981!(VALUE=84378)!(VALUE=84431)!(VALUE=84317)!(VALUE=84089) D
... S DIK="^ATXAX("_DA(1)_",21," D ^DIK
;
NEW TAX,DIC,X,TDA,Y
S DIC="^ATXAX(",DIC(0)="Z"
S TAX="BKMV PI MEDS",X=TAX D ^DIC S TDA=+Y
I TDA'=-1 D
. NEW DA,VALUE
. S DA(1)=TDA,DA=0
. F S DA=$O(^ATXAX(TDA,21,DA)) Q:'DA D
.. S VALUE=$P(^ATXAX(TDA,21,DA,0),U,1)
.. I VALUE=84281!(VALUE=84374)!(VALUE=84318) D
... S DIK="^ATXAX("_DA(1)_",21," D ^DIK
Q
;
PTCH2 ; Patch 2 post install fixes
; Set up new taxonomies for STI
D ^BKMETX
;
LLTAX ; Add Lab Taxonomies to ^ATXLAB
NEW X,DIC,DLAYGO,DA,DR,DIE,Y,LTAX
S DIC="^ATXLAB(",DIC(0)="L",DLAYGO=9002228
; Loop through the Taxonomies as stored in routine BKMVTAX4.
D LDLAB(.LTAX)
F BJ=1:1 Q:'$D(LTAX(BJ)) S X=LTAX(BJ) D
. I $D(^ATXLAB("B",X)) Q ; Skip pre-existing Lab taxonomies
. D ^DIC S DA=+Y
. I DA<1 Q
. S BQTXUP(9002228,DA_",",.02)=$P(X," ",2,999)
. S BQTXUP(9002228,DA_",",.05)=DUZ
. S BQTXUP(9002228,DA_",",.06)=DT
. S BQTXUP(9002228,DA_",",.09)=60
. D FILE^DIE("I","BQTXUP")
. S BQTXUP(9002228,DA_",",.08)="B"
. D FILE^DIE("E","BQTXUP")
;
K DA,BJ,BQTXUP
Q
;
LDLAB(ARRAY) ;EP - Load site-populated Lab tests
NEW I,TEXT
F I=1:1 S TEXT=$P($T(LAB+I),";;",2) Q:TEXT="" S ARRAY(I)=TEXT
Q
;
LAB ;LAB TESTS (SITE-POPULATED)
;;BGP CHLAMYDIA TESTS TAX
;;BGP HIV TEST TAX
;;BKM GONORRHEA TEST TAX
;;BKM HEP B TAX
;;BKM FTA-ABS TEST TAX
;;BKM RPR TAX
;;
BKM11PST ;APTIV/HC/ALA-Ver 1.1 Post Install ; 10 Jan 2008 11:30 AM
+1 ;;2.0;HIV MANAGEMENT SYSTEM;;May 29, 2009
+2 ;
+3 ;**Program Description**
+4 ; This is the post-installation program to set up values for the
+5 ; HIV Management System
+6 ;
EN ; Entry Point
+1 ;
+2 ; Never before installed
+3 IF $ORDER(^BKM(90450,0))=""
Begin DoDot:1
+4 DO INIT
End DoDot:1
+5 ;
+6 IF '$$PATCH^XPDUTL("BKM*1.0*1")
DO PTCH1
+7 IF '$$PATCH^XPDUTL("BKM*1.0*2")
DO PTCH2
+8 ;
+9 QUIT
+10 ;
PRE ; Preinstall
+1 NEW DA,DIK
+2 SET DIK="^BKM(90454,"
+3 SET DA=0
+4 FOR
SET DA=$ORDER(^BKM(90454,DA))
IF 'DA
QUIT
DO ^DIK
+5 ;
+6 SET DA=1
SET DIK="^BKM(90456,"
DO ^DIK
+7 ;
+8 NEW DA,DIK
+9 SET DIK="^BKM(90450,"
SET DA=1
DO ^DIK
+10 QUIT
+11 ;
INIT ; Set up the HIV registry entry
+1 NEW X,DIC,DLAYGO,REGISTER,DA,DR,DIE,Y
+2 SET X="HMS REGISTER"
SET DIC(0)="LMNZ"
SET DLAYGO=90450
SET DIC="^BKM(90450,"
+3 DO ^DIC
+4 SET (REGISTER,DA)=+Y
+5 SET DR=".02////HMS;12////1;12.5////1;19////0"
SET DIE=DIC
DO ^DIE
+6 ;
+7 ; Add the intro text for autopopulate
+8 NEW BI,LM
KILL ^TMP($JOB,"BKMTXT")
+9 FOR BI=1:1:18
SET LM=$TEXT(TXT+BI)
IF LM=" Q"
QUIT
SET ^TMP($JOB,"BKMTXT",BI,0)=$PIECE(LM,";;",2)
+10 DO WP^DIE(90450,REGISTER,50,"","^TMP($J,""BKMTXT"")")
+11 KILL ^TMP($JOB,"BKMTXT")
+12 ;
QM ; Set up QMAN entries
+1 NEW X,DIC,DLAYGO,DA,DR,DIE,LINK,Y,TERM
+2 SET X="PATIENT;IMM"
SET DIC(0)="LMNZ"
SET DLAYGO=9009071
SET DIC="^AMQQ(1,"
+3 DO ^DIC
+4 SET (DA,LINK)=+Y
+5 SET BKMUPD(9009071,LINK_",",1)=9999999.14
SET BKMUPD(9009071,LINK_",",2)=9000010.11
+6 SET BKMUPD(9009071,LINK_",",3)=".01"
SET BKMUPD(9009071,LINK_",",4)=10
SET BKMUPD(9009071,LINK_",",7)=1
+7 DO FILE^DIE("","BKMUPD")
+8 KILL BKMUPD,X,DA,DIC,DIE,DLAYGO,Y
+9 ;
+10 SET X="HMS IMMUNIZATION"
SET DIC(0)="LMNZ"
SET DLAYGO=9009075
SET DIC="^AMQQ(5,"
+11 DO ^DIC
+12 SET (DA,TERM)=+Y
+13 SET BKMUPD(9009075,TERM_",",1)="P"
SET BKMUPD(9009075,TERM_",",3)=1
SET BKMUPD(9009075,TERM_",",4)=LINK
+14 SET BKMUPD(9009075,TERM_",",13)=3
SET BKMUPD(9009075,TERM_",",14)="IMMUNIZATION"
+15 SET BKMUPD(9009075,TERM_",",18)="AUTTIMM("
SET BKMUPD(9009075,TERM_",",19)="C"
+16 SET BKMUPD(9009075,TERM_",",20)="M"
+17 DO FILE^DIE("","BKMUPD")
+18 KILL BKMUPD,X,DA,DIC,DIE,DLAYGO,Y
+19 ;
+20 SET X="HMS IMMUNIZATIONS"
SET DA(1)=TERM
SET DIC(0)="LMNZ"
SET DIC="^AMQQ(5,"_DA(1)_",1,"
SET DLAYGO=9009075.01
+21 DO ^DIC
+22 ;
+23 NEW X,DIC,DLAYGO,DA,DR,DIE,LINK,Y,TERM
+24 SET X="PATIENT;LOINC"
SET DIC(0)="LMNZ"
SET DLAYGO=9009071
SET DIC="^AMQQ(1,"
+25 DO ^DIC
+26 SET (DA,LINK)=+Y
+27 SET BKMUPD(9009071,LINK_",",1)=95.3
SET BKMUPD(9009071,LINK_",",2)=9000010.09
+28 SET BKMUPD(9009071,LINK_",",3)=".01"
SET BKMUPD(9009071,LINK_",",4)=10
SET BKMUPD(9009071,LINK_",",7)=1
+29 DO FILE^DIE("","BKMUPD")
+30 KILL BKMUPD,X,DA,DIC,DIE,DLAYGO,Y
+31 ;
+32 SET X="LOINC"
SET DIC(0)="LMNZ"
SET DLAYGO=9009075
SET DIC="^AMQQ(5,"
+33 DO ^DIC
+34 SET (DA,TERM)=+Y
+35 SET BKMUPD(9009075,TERM_",",1)="P"
SET BKMUPD(9009075,TERM_",",3)=4
SET BKMUPD(9009075,TERM_",",4)=LINK
+36 SET BKMUPD(9009075,TERM_",",13)=3
SET BKMUPD(9009075,TERM_",",14)="LOINC"
+37 SET BKMUPD(9009075,TERM_",",18)="LAB(95.3,"
SET BKMUPD(9009075,TERM_",",19)="C"
+38 SET BKMUPD(9009075,TERM_",",20)="M"
+39 DO FILE^DIE("","BKMUPD")
+40 KILL BKMUPD,X,DA,DIC,DIE,DLAYGO,Y
+41 ;
+42 SET X="HMS IMMUNIZATIONS"
SET DA(1)=TERM
SET DIC(0)="LMNZ"
SET DIC="^AMQQ(5,"_DA(1)_",1,"
SET DLAYGO=9009075.01
+43 DO ^DIC
+44 ;
+1 SET MOK=$$ADD^XPDMENU("BKMV REPORTS","BGPMENU","GPRA",7)
+2 SET MOK=$$ADD^XPDMENU("BKMV OTHER RPMS","LR IHS MENU")
+3 SET MOK=$$ADD^XPDMENU("BKMV OTHER RPMS","PSO USER1")
+4 SET MOK=$$ADD^XPDMENU("BKMV OTHER RPMS","GMRAMGR")
+5 SET MOK=$$ADD^XPDMENU("BKMV OTHER RPMS","AGMENU")
+6 SET MOK=$$ADD^XPDMENU("BKMV OTHER RPMS","BMCMENU")
+7 SET MOK=$$ADD^XPDMENU("BKMV OTHER RPMS","AMQQMENU")
+8 SET MOK=$$ADD^XPDMENU("BKMV OTHER RPMS","BSDMENU")
+9 SET MOK=$$ADD^XPDMENU("XUCORE","BKMVMENU","HMS",7)
+10 KILL MOK
+11 ;
BLR ;
+1 ; Check the IHS LAB CPT CODE File for bad pointers
+2 NEW CT,BLN,LBN,XMY,XMZ
+3 KILL ^TMP("BQIMAIL",$JOB)
+4 SET BLN=0
SET CT=0
+5 FOR
SET BLN=$ORDER(^BLRCPT(BLN))
IF 'BLN
QUIT
Begin DoDot:1
+6 SET LBN=$PIECE($GET(^BLRCPT(BLN,1)),U,1)
+7 IF LBN=""
QUIT
+8 IF $GET(^LAB(60,LBN,0))'=""
QUIT
+9 SET CT=CT+1
SET ^TMP("BQIMAIL",$JOB,CT,0)="The "_$PIECE(^BLRCPT(BLN,0),U,1)_" record in the IHS LAB CPT CODE File #9009021 PANEL/TEST pointer does not exist in the LAB TEST File #60."
End DoDot:1
+10 IF $DATA(^TMP("BQIMAIL",$JOB))>0
Begin DoDot:1
+11 SET CT=CT+1
SET ^TMP("BQIMAIL",$JOB,CT,0)=" "
+12 SET CT=CT+1
SET ^TMP("BQIMAIL",$JOB,CT,0)="Go to option BLR EDIT IHS LAB CPT FILE to correct these records."
+13 SET XMSUB="iCare Install Problem"
+14 SET XMTEXT="^TMP(""BQIMAIL"",$J,"
+15 IF $GET(DUZ)'=""
SET XMDUZ=DUZ
SET XMY(DUZ)=""
+16 IF $GET(DUZ)=""
SET XMDUZ="iCare Install"
+17 SET XMY(DUZ)=""
+18 NEW BDUZ
+19 SET BDUZ=""
FOR
SET BDUZ=$ORDER(^XUSEC("LRLIASON",BDUZ))
IF BDUZ=""
QUIT
Begin DoDot:2
+20 IF $PIECE($GET(^VA(200,BDUZ,0)),U,11)'=""
QUIT
+21 SET XMY(BDUZ)=""
End DoDot:2
+22 IF '$DATA(XMY)
SET XMY(.5)=""
+23 DO ^XMD
End DoDot:1
+24 ;
LTAX ; Add Lab Taxonomies to ^ATXLAB
+1 NEW X,DIC,DLAYGO,DA,DR,DIE,Y,LTAX
+2 SET DIC="^ATXLAB("
SET DIC(0)="L"
SET DLAYGO=9002228
+3 ; Loop through the Taxonomies as stored in routine BKMVTAX4.
+4 DO LDLAB^BKMVTAX4(.LTAX)
+5 FOR BJ=1:1
IF '$DATA(LTAX(BJ))
QUIT
SET X=LTAX(BJ)
Begin DoDot:1
+6 ; Skip pre-existing Lab taxonomies
IF $DATA(^ATXLAB("B",X))
QUIT
+7 DO ^DIC
SET DA=+Y
+8 IF DA<1
QUIT
+9 SET BKTXUP(9002228,DA_",",.02)=$PIECE(X," ",2,999)
+10 SET BKTXUP(9002228,DA_",",.05)=DUZ
+11 SET BKTXUP(9002228,DA_",",.06)=DT
+12 SET BKTXUP(9002228,DA_",",.09)=60
+13 DO FILE^DIE("I","BKTXUP")
+14 SET BKTXUP(9002228,DA_",",.08)="B"
+15 DO FILE^DIE("E","BKTXUP")
End DoDot:1
+16 ;
+17 KILL DA,BJ,BKTXUP
+18 ;
TAX ; Set up the taxonomies
+1 DO ^BKMTX
+2 DO ^BKMATX
+3 DO ^BKMBTX
+4 DO ^BKMCTX
+5 DO ^BKMDTX
+6 ;
USR ; Set up the Case File Manager
+1 ;D CFM^BKMVB1
+2 KILL IEN,HIVIEN,GETDFN,BKMUSER,OCCUP,USER,X,Y
+3 ;
+4 ; PRXM/HC/BHS - 05/10/2006 - Convert UN code to UNR per IHS
UNR ; Check the HMS CANDIDATE File for Status (.03) = "UN" and
+1 ; if found convert to "UNR"
+2 NEW DA,DIE,DR,STATUS
+3 SET DA=0
+4 FOR
SET DA=$ORDER(^BKM(90451.2,DA))
IF 'DA
QUIT
Begin DoDot:1
+5 SET STATUS=$$GET1^DIQ(90451.2,DA,".03","I")
+6 ; Only convert UN code to UNR
+7 IF STATUS'="UN"
QUIT
+8 SET DIE="^BKM(90451.2,"
SET DR=".03///UNR"
+9 DO ^DIE
End DoDot:1
+10 ;
+11 QUIT
+12 ;
TXT ; Text to be stored
+1 ;;The autopopulate function will search your RPMS database to identify
+2 ;;patient candidates for your site's HMS Register. You can review your
+3 ;;candidate list (REV option) after the autopopulate and move selected
+4 ;;patients to the Register.
+5 ;;
+6 ;;HMS uses the following logic to identify patients as candidates:
+7 ;; 1. at least one POV or Problem List diagnosis of HIV ever; or
+8 ;; 2. a positive result on an HIV test; or
+9 ;; 3. at least 2 of any antiretroviral medications (NRTI, NNRTI, PI or
+10 ;; FI medications)
+11 ;;
+12 ;;See the User Manual for complete, detailed definitions and related
+13 ;;taxonomies.
+14 ;;
+15 ;;Checking for Taxonomies . . .
+16 ;;
+17 ;;In order for the HMS autopopulate function to find all necessary data,
+18 ;;several taxonomies must be established.
+19 QUIT
+20 ;
PTCH1 ; Patch 1 postinstall fixes
+1 ; Check candidate list and remove entries
+2 NEW DFN,MED,DFLG,STAT,TAX
+3 SET DFN=0
+4 FOR
SET DFN=$ORDER(^BKM(90451.2,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+5 SET STAT=$PIECE(^BKM(90451.2,DFN,0),U,3)
+6 IF STAT="NOT"!(STAT="REM")
QUIT
+7 SET MED=0
SET DFLG=0
+8 FOR
SET MED=$ORDER(^BKM(90451.2,DFN,3,MED))
IF 'MED
QUIT
Begin DoDot:2
+9 SET TAX=$PIECE(^BKM(90451.2,DFN,3,MED,0),U,3)
+10 IF TAX="BKMV EI MEDS"!(TAX="BKMV NNRTI MEDS")!(TAX="BKMV NRTI MEDS")!(TAX="BKMV PI MEDS")
SET DFLG=1
QUIT
End DoDot:2
IF DFLG
QUIT
+11 IF DFLG
Begin DoDot:2
+12 NEW DA,DIK
+13 SET DA=DFN
SET DIK="^BKM(90451.2,"
DO ^DIK
End DoDot:2
End DoDot:1
+14 ;
TX ; Check taxonomies
+1 NEW TAX,DIC,X,TDA,Y
+2 SET DIC="^ATXAX("
SET DIC(0)="Z"
+3 SET TAX="BKMV EI MEDS"
SET X=TAX
DO ^DIC
SET TDA=+Y
+4 IF TDA'=-1
Begin DoDot:1
+5 NEW DA,VALUE
+6 SET DA(1)=TDA
SET DA=0
+7 FOR
SET DA=$ORDER(^ATXAX(TDA,21,DA))
IF 'DA
QUIT
Begin DoDot:2
+8 SET VALUE=$PIECE(^ATXAX(TDA,21,DA,0),U,1)
+9 IF VALUE=5201!(VALUE=83677)!(VALUE=84151)
Begin DoDot:3
+10 SET DIK="^ATXAX("_DA(1)_",21,"
DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;
+12 NEW TAX,DIC,X,TDA,Y
+13 SET DIC="^ATXAX("
SET DIC(0)="Z"
+14 SET TAX="BKMV NNRTI MEDS"
SET X=TAX
DO ^DIC
SET TDA=+Y
+15 IF TDA'=-1
Begin DoDot:1
+16 NEW DA,VALUE
+17 SET DA(1)=TDA
SET DA=0
+18 FOR
SET DA=$ORDER(^ATXAX(TDA,21,DA))
IF 'DA
QUIT
Begin DoDot:2
+19 SET VALUE=$PIECE(^ATXAX(TDA,21,DA,0),U,1)
+20 IF VALUE=84282!(VALUE=84317)!(VALUE=84318)
Begin DoDot:3
+21 SET DIK="^ATXAX("_DA(1)_",21,"
DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
+23 NEW TAX,DIC,X,TDA,Y
+24 SET DIC="^ATXAX("
SET DIC(0)="Z"
+25 SET TAX="BKMV NRTI MEDS"
SET X=TAX
DO ^DIC
SET TDA=+Y
+26 IF TDA'=-1
Begin DoDot:1
+27 NEW DA,VALUE
+28 SET DA(1)=TDA
SET DA=0
+29 FOR
SET DA=$ORDER(^ATXAX(TDA,21,DA))
IF 'DA
QUIT
Begin DoDot:2
+30 SET VALUE=$PIECE(^ATXAX(TDA,21,DA,0),U,1)
+31 IF VALUE=83981!(VALUE=84378)!(VALUE=84431)!(VALUE=84317)!(VALUE=84089)
Begin DoDot:3
+32 SET DIK="^ATXAX("_DA(1)_",21,"
DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;
+34 NEW TAX,DIC,X,TDA,Y
+35 SET DIC="^ATXAX("
SET DIC(0)="Z"
+36 SET TAX="BKMV PI MEDS"
SET X=TAX
DO ^DIC
SET TDA=+Y
+37 IF TDA'=-1
Begin DoDot:1
+38 NEW DA,VALUE
+39 SET DA(1)=TDA
SET DA=0
+40 FOR
SET DA=$ORDER(^ATXAX(TDA,21,DA))
IF 'DA
QUIT
Begin DoDot:2
+41 SET VALUE=$PIECE(^ATXAX(TDA,21,DA,0),U,1)
+42 IF VALUE=84281!(VALUE=84374)!(VALUE=84318)
Begin DoDot:3
+43 SET DIK="^ATXAX("_DA(1)_",21,"
DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+44 QUIT
+45 ;
PTCH2 ; Patch 2 post install fixes
+1 ; Set up new taxonomies for STI
+2 DO ^BKMETX
+3 ;
LLTAX ; Add Lab Taxonomies to ^ATXLAB
+1 NEW X,DIC,DLAYGO,DA,DR,DIE,Y,LTAX
+2 SET DIC="^ATXLAB("
SET DIC(0)="L"
SET DLAYGO=9002228
+3 ; Loop through the Taxonomies as stored in routine BKMVTAX4.
+4 DO LDLAB(.LTAX)
+5 FOR BJ=1:1
IF '$DATA(LTAX(BJ))
QUIT
SET X=LTAX(BJ)
Begin DoDot:1
+6 ; Skip pre-existing Lab taxonomies
IF $DATA(^ATXLAB("B",X))
QUIT
+7 DO ^DIC
SET DA=+Y
+8 IF DA<1
QUIT
+9 SET BQTXUP(9002228,DA_",",.02)=$PIECE(X," ",2,999)
+10 SET BQTXUP(9002228,DA_",",.05)=DUZ
+11 SET BQTXUP(9002228,DA_",",.06)=DT
+12 SET BQTXUP(9002228,DA_",",.09)=60
+13 DO FILE^DIE("I","BQTXUP")
+14 SET BQTXUP(9002228,DA_",",.08)="B"
+15 DO FILE^DIE("E","BQTXUP")
End DoDot:1
+16 ;
+17 KILL DA,BJ,BQTXUP
+18 QUIT
+19 ;
LDLAB(ARRAY) ;EP - Load site-populated Lab tests
+1 NEW I,TEXT
+2 FOR I=1:1
SET TEXT=$PIECE($TEXT(LAB+I),";;",2)
IF TEXT=""
QUIT
SET ARRAY(I)=TEXT
+3 QUIT
+4 ;
LAB ;LAB TESTS (SITE-POPULATED)
+1 ;;BGP CHLAMYDIA TESTS TAX
+2 ;;BGP HIV TEST TAX
+3 ;;BKM GONORRHEA TEST TAX
+4 ;;BKM HEP B TAX
+5 ;;BKM FTA-ABS TEST TAX
+6 ;;BKM RPR TAX
+7 ;;
