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

BQI23P1.m

Go to the documentation of this file.
  1. BQI23P1 ;VNGT/HS/ALA-Install Program v 2.3 Patch 1 ; 25 May 2011 7:31 AM
  1. ;;2.3;ICARE MANAGEMENT SYSTEM;**1**;Apr 18, 2012;Build 43
  1. ;
  1. PRE ; Pre-install
  1. NEW DA,DIK
  1. S DIK="^BQI(90506,",DA=0
  1. F S DA=$O(^BQI(90506,DA)) Q:'DA D ^DIK
  1. S DIK="^BQI(90507.8,",DA=0
  1. F S DA=$O(^BQI(90507.8,DA)) Q:'DA D ^DIK
  1. S DIK="^BQI(90506.5,",DA=0
  1. F S DA=$O(^BQI(90506.5,DA)) Q:'DA D ^DIK
  1. S DIK="^BQI(90508.6,",DA=0
  1. F S DA=$O(^BQI(90508.6,DA)) Q:'DA D ^DIK
  1. S DIK="^BQI(90506.8,",DA=0
  1. F S DA=$O(^BQI(90506.8,DA)) Q:'DA D ^DIK
  1. S DA=0,DIK="^BQI(90509.9,"
  1. F S DA=$O(^BQI(90509.9,DA)) Q:'DA D ^DIK
  1. ;
  1. K ^BQI(90506.2,3,6)
  1. Q
  1. ;
  1. POS ; Post-Install
  1. ;
  1. S $P(^BQI(90508,1,0),U,24)="36M"
  1. ; Clean up new style cross-reference
  1. NEW DIK
  1. K ^BQI(90507.7,"AC")
  1. S DIK="^BQI(90507.7," D IXALL^DIK
  1. ;
  1. ; Update flags
  1. NEW N,CT
  1. S N=0
  1. F S N=$O(^BQIPAT(N)) Q:'N K ^BQIPAT(N,10) S CT=$G(CT)+1 W:CT#500 "."
  1. ;
  1. ; Update Provider Edit V Form
  1. NEW VN,CN
  1. S VN=$O(^BQI(90506.3,"B","Designated Provider",""))
  1. I VN'="" D
  1. . S CN=$O(^BQI(90506.3,VN,10,"B","Last Modified By",""))
  1. . I CN'="" D
  1. .. S ^BQI(90506.3,VN,10,CN,1)="D^^^^D"
  1. . S CN=$O(^BQI(90506.3,VN,10,"B","Last Modified Date",""))
  1. . I CN'="" D
  1. .. S ^BQI(90506.3,VN,10,CN,1)="T^^^^D"
  1. ;
  1. ; Update Medication PCC V Form to remove from list
  1. S VN=$O(^BQI(90506.3,"B","Medication",""))
  1. I VN'="" S $P(^BQI(90506.3,VN,0),"^",5)=1
  1. ;
  1. NEW BDZ,AIEN
  1. S BDZ=0
  1. F S BDZ=$O(^BQICARE(BDZ)) Q:'BDZ D
  1. . F BQCN=55,75 D
  1. .. S AIEN=$O(^BQICARE(BDZ,11,"B",BQCN,"")) I AIEN="" Q
  1. .. NEW DA,DIK
  1. .. S DA(1)=BDZ,DA=AIEN,DIK="^BQICARE("_DA(1)_",11," D ^DIK
  1. . ;
  1. . NEW NFN,DA,IENS
  1. . S NFN=$O(^BQICARE(BDZ,10,"B",17,"")) I NFN="" Q
  1. . S DA(1)=BDZ,DA=NFN,IENS=$$IENS^DILF(.DA)
  1. . S BQIUPD(90505.09,IENS,.01)=12
  1. . D FILE^DIE("","BQIUPD","ERROR")
  1. ;
  1. D DX
  1. ;
  1. ; Update CMET
  1. S ^BTPW(90621.1,13,0)="V SKIN TEST^9000010.12^.01^^^O^6^9999999.28"
  1. S ^BTPW(90621.2,6,0)="STI^ST",^BTPW(90621.2,"B","STI",6)=""
  1. NEW IEN,EVT,BQIUPD
  1. F IEN=2,14,16 S BQIUPD(90621,IEN_",",.1)=6
  1. D FILE^DIE("","BQIUPD","ERROR")
  1. F EVT=2,14,16 D
  1. . S IEN=""
  1. . F S IEN=$O(^BTPWQ("B",EVT,IEN)) Q:IEN="" S BQIUPD(90629,IEN_",",.13)=6
  1. . F S IEN=$O(^BTPWP("B",EVT,IEN)) Q:IEN="" S BQIUPD(90620,IEN_",",.12)=6
  1. I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
  1. ;
  1. NEW DA,DIK
  1. S DA=13,DIK="^BTPW(90621.1," D IX^DIK
  1. ;
  1. ; Removed the BGP COLO DXS taxonomy
  1. S DA(1)=51,DA=3,DIK="^BTPW(90621,"_DA(1)_",1," D ^DIK
  1. ;
  1. ; Removed the BGP PAP SMEAR DXS taxonomy
  1. S DA(1)=29,DA=2,DIK="^BTPW(90621,"_DA(1)_",1," D ^DIK
  1. ;
  1. ; Inactivate the OB/GYN CONSULT event in CMET
  1. S $P(^BTPW(90621,27,0),U,3)=DT,$P(^(0),U,4)="N"
  1. ;
  1. NEW TXN,N,VAL,DA,IENS,BQIUPD
  1. S TXN=$O(^ATXAX("B","BTPW COLP IMP NO BX CPTS",""))
  1. I TXN'="" D
  1. . S N=0
  1. . F S N=$O(^ATXAX(TXN,21,N)) Q:'N D
  1. .. S DA(1)=TXN,DA=N,IENS=$$IENS^DILF(.DA)
  1. .. S VAL=$P(^ATXAX(TXN,21,N,0),U,1)
  1. .. I $E(VAL,$L(VAL))'=" " S VAL=VAL_" "
  1. .. S BQIUPD(9002226.02101,IENS,.01)=VAL
  1. .. S BQIUPD(9002226.02101,IENS,.02)=VAL
  1. . D FILE^DIE("","BQIUPD","ERROR")
  1. ;
  1. GLS ; Update glossary
  1. NEW GN,GNM,GSN,BQIUPD
  1. S GN=0
  1. F S GN=$O(^BQI(90509.9,GN)) Q:'GN D
  1. . S GNM=$P(^BQI(90509.9,GN,0),U,1)
  1. . S GSN=$O(^BQI(90508.2,"B",GNM,"")) Q:GSN=""
  1. . S BQIUPD(90508.2,GSN_",",1)="@"
  1. . D FILE^DIE("","BQIUPD","ERROR")
  1. . M ^BQI(90508.2,GSN,1)=^BQI(90509.9,GN,1)
  1. ;
  1. ; Update taxonomies
  1. D EN^BQI23PUC
  1. ;
  1. IPC ; Update for IPC4
  1. I $P($G(^BQI(90508,1,"GPRA")),U,1)=2012 D
  1. . I $P(^BGPINDWC(1237,0),U,4)="HED.CWP.1" D
  1. .. S ^BGPINDWC(1237,17)="9^3^Appropriate Testing for Pharyngitis (2-18)^^^O^1"
  1. .. S ^BGPINDWC(1237,18,0)="^^3^3^3120926^"
  1. .. S ^BGPINDWC(1237,18,1,0)="Active Clinical patients who were ages 2-18 years who were diagnosed with "
  1. .. S ^BGPINDWC(1237,18,2,0)="pharyngitis and prescribed an antibiotic during the period six months "
  1. .. S ^BGPINDWC(1237,18,3,0)="(182 days) prior to the Report period."
  1. .. D GCHK^BQIGPUPD(0)
  1. ;
  1. ; Update IPC measures
  1. D ^BQI23PU4
  1. ;
  1. NEW PRV,DA,IEN,IENS,FAC
  1. S PRV=0
  1. F S PRV=$O(^BQIPROV(PRV)) Q:'PRV D
  1. . S IEN=$O(^BQIPROV(PRV,30,"B","2012_2045","")) I IEN="" Q
  1. . S DA(1)=PRV,DA=IEN,IENS=$$IENS^DILF(.DA)
  1. . S BQIUPD(90505.43,IENS,.01)="2012_1966"
  1. S FAC=$O(^BQIFAC(0))
  1. I FAC S IEN=$O(^BQIFAC(FAC,30,"B","2012_2045",""))
  1. I IEN'="" D
  1. . S DA(1)=FAC,DA=IEN,IENS=$$IENS^DILF(.DA)
  1. . S BQIUPD(90505.63,IENS,.01)="2012_1966"
  1. S BQIUPD(90508,"1,",11)="IPC4"
  1. D FILE^DIE("","BQIUPD","ERROR")
  1. ;
  1. Q
  1. ;
  1. DX ; Check diagnosis code pointers
  1. NEW CN,DN,DXC,DXN
  1. S CN=0
  1. F S CN=$O(^BQI(90507.8,CN)) Q:'CN D
  1. . S DN=0
  1. . F S DN=$O(^BQI(90507.8,CN,10,DN)) Q:'DN D
  1. .. S DXC=$P(^BQI(90507.8,CN,10,DN,0),U,2)_" "
  1. .. S DXN=$$FIND1^DIC(80,"","X",DXC,"BA","","ERROR")
  1. .. I $P(^BQI(90507.8,CN,10,DN,0),U,1)=DXN Q
  1. .. NEW DA,IENS
  1. .. S DA(1)=CN,DA=DN,IENS=$$IENS^DILF(.DA)
  1. .. S BQIUPD(90507.801,IENS,.01)=DXN
  1. . S TN=0
  1. . F S TN=$O(^BQI(90507.8,CN,11,TN)) Q:'TN D
  1. .. S TAX=$P(^BQI(90507.8,CN,11,TN,0),U,1)
  1. .. S VAL=$$STXPT(TAX,"N")
  1. .. NEW DA,IENS
  1. .. S DA(1)=CN,DA=TN,IENS=$$IENS^DILF(.DA)
  1. .. S BQIUPD(90507.811,IENS,.02)=VAL
  1. I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
  1. K BQIUPD
  1. Q
  1. ;
  1. STXPT(TXNM,TYP) ; Set taxonomy pointer
  1. ;
  1. ;Input
  1. ; TXNM - Taxonomy name
  1. ; TYP - Taxonomy Type (L = LAB, N = Non Lab)
  1. NEW IEN,SIEN,DA,IENS,BQUPD,VALUE,GLB
  1. S VALUE=""
  1. I TYP="L" D
  1. . S IEN=$O(^ATXLAB("B",TXNM,"")),GLB="ATXLAB("
  1. . I IEN="" S TYP="N"
  1. I TYP="N" S IEN=$O(^ATXAX("B",TXNM,"")),GLB="ATXAX("
  1. I IEN="" S VALUE="@"
  1. I IEN'="" S VALUE=IEN_";"_GLB
  1. Q VALUE