BKM1POST ;PRXM/HC/ALA - HMS Version 1.0 Post-Installation ; 21 Jul 2005 9:46 PM
;;1.0;HIV MANAGEMENT SYSTEM;;Sep 08, 2006
;
;**Program Description**
; This is the post-installation program to set up values for the
; HIV Management System
;
EN ; Entry Point
;
; 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
BKM1POST ;PRXM/HC/ALA - HMS Version 1.0 Post-Installation ; 21 Jul 2005 9:46 PM
+1 ;;1.0;HIV MANAGEMENT SYSTEM;;Sep 08, 2006
+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 ; Set up the HIV registry entry
+3 NEW X,DIC,DLAYGO,REGISTER,DA,DR,DIE,Y
+4 SET X="HMS REGISTER"
SET DIC(0)="LMNZ"
SET DLAYGO=90450
SET DIC="^BKM(90450,"
+5 DO ^DIC
+6 SET (REGISTER,DA)=+Y
+7 SET DR=".02////HMS;12////1;12.5////1;19////0"
SET DIE=DIC
DO ^DIE
+8 ;
+9 ; Add the intro text for autopopulate
+10 NEW BI,LM
KILL ^TMP($JOB,"BKMTXT")
+11 FOR BI=1:1:18
SET LM=$TEXT(TXT+BI)
IF LM=" Q"
QUIT
SET ^TMP($JOB,"BKMTXT",BI,0)=$PIECE(LM,";;",2)
+12 DO WP^DIE(90450,REGISTER,50,"","^TMP($J,""BKMTXT"")")
+13 KILL ^TMP($JOB,"BKMTXT")
+14 ;
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 DO 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
