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

BKM2POST.m

Go to the documentation of this file. 
  1. BKM2POST ;APTIV/HC/ALA-Post Install for version 2.0 ; 28 Jan 2008  5:33 PM
  1.  ;;2.0;HIV MANAGEMENT SYSTEM;;May 29, 2009
  1.  ;
  1.  ;
  1. EN ;Entry point
  1.  NEW DA,DIK
  1.  S DA(1)=1,DA=0,DIK="^BKM(90450,"_DA(1)_",11,"
  1.  F  S DA=$O(^BKM(90450,1,11,DA)) Q:'DA  D ^DIK
  1.  M ^BKM(90450,1,11)=^XTMP("BKM 2.0",11)
  1.  K ^XTMP("BKM 2.0")
  1.  ;
  1.  ; Set up date to inactivate the roll and scroll version of HMS
  1.  NEW BKMHIV,BKMUPD,NM,IEN
  1.  S BKMHIV=$$HIVIEN^BKMIXX3()
  1.  S BKMUPD(90450,BKMHIV_",",.08)=$$DATE^BQIUL1("T+3M")
  1.  S BKMUPD(90450,BKMHIV_",",30)="@"
  1.  S NM="BKM"
  1.  F  S NM=$O(^DIC(19,"B",NM)) Q:NM=""!($E(NM,1,3)'="BKM")  D
  1.  . S IEN=""
  1.  . F  S IEN=$O(^DIC(19,"B",NM,IEN)) Q:IEN=""  D
  1.  .. S BKMUPD(19,IEN_",",2)="@"
  1.  D FILE^DIE("","BKMUPD","ERROR")
  1.  ;
  1.  ; Add new HIV taxonomies
  1.  D ^BKMFTX
  1.  D ^BKMGTX
  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(.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.  ;
  1.  ; Update site-defined medication taxonomies
  1.  NEW BGPX,BGPNDCT
  1.  S BGPX="BKMV EI MEDS",BGPNDCT="BKMV EI MED NDCS" D
  1.  . I $O(^ATXAX("B",BGPX,""))="" D ^BKMTXB
  1.  . I $O(^ATXAX("B",BGPNDCT,""))="" D ^BQIBTXD
  1.  . D SITEMED^BQI2POST(BGPX,BGPNDCT)
  1.  S BGPX="BKMV II MEDS",BGPNDCT="BKMV II MED NDCS" D
  1.  . I $O(^ATXAX("B",BGPX,""))="" D ^BQIBTXL
  1.  . I $O(^ATXAX("B",BGPNDCT,""))="" D ^BQIBTXE
  1.  . D SITEMED^BQI2POST(BGPX,BGPNDCT)
  1.  S BGPX="BKMV MAC PROPH MEDS",BGPNDCT="BKMV MAC PROPH MED NDCS" D
  1.  . I $O(^ATXAX("B",BGPX,""))="" D ^BKMTXC
  1.  . I $O(^ATXAX("B",BGPNDCT,""))="" D ^BQIBTXF
  1.  . D SITEMED^BQI2POST(BGPX,BGPNDCT)
  1.  S BGPX="BKMV NNRTI MEDS",BGPNDCT="BKMV NNRTI MED NDCS" D
  1.  . I $O(^ATXAX("B",BGPX,""))="" D ^BKMTXD
  1.  . I $O(^ATXAX("B",BGPNDCT,""))="" D ^BQIBTXG
  1.  . D SITEMED^BQI2POST(BGPX,BGPNDCT)
  1.  S BGPX="BKMV NRTI MEDS",BGPNDCT="BKMV NRTI MED NDCS" D
  1.  . I $O(^ATXAX("B",BGPX,""))="" D ^BKMTXE
  1.  . I $O(^ATXAX("B",BGPNDCT,""))="" D ^BQIBTXH
  1.  . D SITEMED^BQI2POST(BGPX,BGPNDCT)
  1.  S BGPX="BKMV NRTI/NNRTI MEDS",BGPNDCT="BKMV NRTI/NNRTI MED NDCS" D
  1.  . I $O(^ATXAX("B",BGPX,""))="" D ^BQIBTXM
  1.  . I $O(^ATXAX("B",BGPNDCT,""))="" D ^BQIBTXI
  1.  . D SITEMED^BQI2POST(BGPX,BGPNDCT)
  1.  S BGPX="BKMV PCP PROPH MEDS",BGPNDCT="BKMV PCP PROPH MED NDCS" D
  1.  . I $O(^ATXAX("B",BGPX,""))="" D ^BKMTXF
  1.  . I $O(^ATXAX("B",BGPNDCT,""))="" D ^BKMDTXP
  1.  . D SITEMED^BQI2POST(BGPX,BGPNDCT)
  1.  S BGPX="BKMV PI MEDS",BGPNDCT="BKMV PI MED NDCS" D
  1.  . I $O(^ATXAX("B",BGPX,""))="" D ^BKMTXG
  1.  . I $O(^ATXAX("B",BGPNDCT,""))="" D ^BQIBTXJ
  1.  . D SITEMED^BQI2POST(BGPX,BGPNDCT)
  1.  S BGPX="BKM TB MEDS",BGPNDCT="BKM TB MED NDCS" D
  1.  . I $O(^ATXAX("B",BGPX,""))="" D ^BKMTXA
  1.  . I $O(^ATXAX("B",BGPNDCT,""))="" D ^BKMDTXD
  1.  . D SITEMED^BQI2POST(BGPX,BGPNDCT)
  1.  S BGPX="BKMV NRTI COMBO MEDS",BGPNDCT="BKMV NRTI COMBO MED NDCS" D
  1.  . I $O(^ATXAX("B",BGPX,""))="" D ^BKMGTXE
  1.  . I $O(^ATXAX("B",BGPNDCT,""))="" D ^BKMFTXZ
  1.  . D SITEMED^BQI2POST(BGPX,BGPNDCT)
  1.  S BGPX="BKMV PI BOOSTER MEDS",BGPNDCT="BKMV PI BOOSTER MED NDCS" D
  1.  . I $O(^ATXAX("B",BGPX,""))="" D ^BKMGTXF
  1.  . I $O(^ATXAX("B",BGPNDCT,""))="" D ^BKMGTXC
  1.  . D SITEMED^BQI2POST(BGPX,BGPNDCT)
  1.  ;
  1. TX ; Reset the variable pointer values for the taxonomies
  1.  NEW BQIDA,N,X,IEN,VAL,BQIUPD
  1.  S BQIDA=1
  1.  S N=0
  1.  F  S N=$O(^BQI(90508,BQIDA,10,N)) Q:'N  D
  1.  . S X=$P(^BQI(90508,BQIDA,10,N,0),U,1)
  1.  . S IEN=N_","_BQIDA_","
  1.  . I $P(^BQI(90508,BQIDA,10,N,0),U,5)="T" S VAL=$$STXPT^BQI2POST(X,"L")
  1.  . E  S VAL=$$STXPT^BQI2POST(X,"N")
  1.  . S BQIUPD(90508.03,IEN,.02)=VAL
  1.  I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
  1.  ;
  1.  NEW REG,N,X,IEN,VAL,BQIUPD,RP
  1.  S REG=0
  1.  F  S REG=$O(^BQI(90507,REG)) Q:'REG  D
  1.  . S N=0
  1.  . F  S N=$O(^BQI(90507,REG,10,N)) Q:'N  D
  1.  .. S X=$P(^BQI(90507,REG,10,N,0),U,1)
  1.  .. S IEN=N_","_REG_","
  1.  .. I $P(^BQI(90507,REG,10,N,0),U,5)="T" S VAL=$$STXPT^BQI2POST(X,"L")
  1.  .. E  S VAL=$$STXPT^BQI2POST(X,"N")
  1.  .. S BQIUPD(90507.01,IEN,.02)=VAL
  1.  . I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
  1.  . ;
  1.  . S RP=0
  1.  . F  S RP=$O(^BQI(90507,REG,20,RP)) Q:'RP  D
  1.  .. S N=0
  1.  .. F  S N=$O(^BQI(90507,REG,20,RP,10,N)) Q:'N  D
  1.  ... S X=$P(^BQI(90507,REG,20,RP,10,N,0),U,1)
  1.  ... S IEN=N_","_RP_","_REG_","
  1.  ... S TIEN=$O(^BQI(90507,REG,10,"B",X,""))
  1.  ... I $P(^BQI(90507,REG,10,TIEN,0),U,5)="T" S VAL=$$STXPT^BQI2POST(X,"L")
  1.  ... E  S VAL=$$STXPT^BQI2POST(X,"N")
  1.  ... S BQIUPD(90507.03,IEN,.02)=VAL
  1.  . I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
  1.  ;
  1.  ; Load HMS Supplement in ^APCHSUP
  1.  NEW BKMDATA,BKMI,BKMJ,BKMD,CIEN
  1.  F BKMI=1 S BKMDATA=$P($T(SUP+BKMI),";;",2) D
  1.  . NEW X,DIC,DA,BKMUPD,Y
  1.  . S X=$P(BKMDATA,"|",1)
  1.  . S DIC="^APCHSUP(",DIC(0)="LZ" D ^DIC
  1.  . ; If this is not a new entry, quit
  1.  . I $P(Y,U,3)'=1 Q
  1.  . S DA=+Y
  1.  . S BKMUPD(9001022,DA_",",1100)=$P(BKMDATA,"|",2)
  1.  . D FILE^DIE("E","BKMUPD","ERROR")
  1.  . F BKMJ=1:1 S BKMD=$T(@("S"_BKMI)+BKMJ) Q:BKMD[" Q"  S BKWP(BKMJ)=$P(BKMD,";;",2)
  1.  . D WP^DIE(9001022,DA_",",1200,"","BKWP","ERROR")
  1.  . K BKWP
  1.  ;
  1.  ;Move the comments into the new fields, if site has populated HMS register
  1.  ;  STATUS COMMENTS, DIAGNOSIS COMMENTS, and ETIOLOGY COMMENTS
  1.  S HIEN=0
  1.  F  S HIEN=$O(^BKM(90451,HIEN)) Q:'HIEN  D
  1.  . S RIEN=0
  1.  . F  S RIEN=$O(^BKM(90451,HIEN,1,RIEN)) Q:'RIEN  D
  1.  .. NEW DA,IENS
  1.  .. S DA(1)=HIEN,DA=RIEN,IENS=$$IENS^DILF(.DA)
  1.  .. S PAIRS="1;20^2.7;21^7.5;22"
  1.  .. S FILE=90451.01
  1.  .. D MOVE(FILE,IENS,PAIRS)
  1.  .. S AIEN=0
  1.  .. F  S AIEN=$O(^BKM(90451,HIEN,1,RIEN,40,AIEN)) Q:'AIEN  D
  1.  ... NEW DA,IENS
  1.  ... S DA(2)=HIEN,DA(1)=RIEN,DA=AIEN,IENS=$$IENS^DILF(.DA)
  1.  ... S PAIRS="3;20",FILE=90451.03
  1.  ... D MOVE(FILE,IENS,PAIRS)
  1.  .. S CIEN=0
  1.  .. F  S CIEN=$O(^BKM(90451,HIEN,1,RIEN,50,CIEN)) Q:'CIEN  D
  1.  ... NEW DA,IENS
  1.  ... S DA(2)=HIEN,DA(1)=RIEN,DA=CIEN,IENS=$$IENS^DILF(.DA)
  1.  ... S PAIRS="2;20",FILE=90451.07
  1.  ... D MOVE(FILE,IENS,PAIRS)
  1.  Q
  1.  ;
  1. MOVE(FILE,IENS,PAIRS) ;EP
  1.  NEW FROM,TO,PAIR
  1.  F I=1:1:$L(PAIRS,U) D
  1.  . S PAIR=$P(PAIRS,U,I),FROM=$P(PAIR,";",1),TO=$P(PAIR,";",2)
  1.  . K TEXT
  1.  . S TEXT(1,0)=$$GET1^DIQ(FILE,IENS,FROM,"E")
  1.  . I $G(TEXT(1,0))="" Q
  1.  . D WP^DIE(FILE,IENS,TO,"","TEXT","ERROR")
  1.  Q
  1.  ;
  1. SUP ; Load HMS Supplement in ^APCHSUP
  1.  ;;HMS PATIENT CARE SUPPLEMENT|D EP^BKMVSUP(APCHSPAT)
  1.  Q
  1.  ;
  1. S1 ;;
  1.  ;;The HMS Supplement has been designed to display information
  1.  ;;specifically related to HIV.  You will be able to see, at a glance, the
  1.  ;;relevant labs, related diagnoses, medications and reminders.
  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 ;EP - LAB TESTS (SITE-POPULATED)
  1.  ;;BKM HEP A TAX
  1.  ;;