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

BKM11PST.m

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