BQI23P1 ;VNGT/HS/ALA-Install Program v 2.3 Patch 1 ; 25 May 2011 7:31 AM
;;2.3;ICARE MANAGEMENT SYSTEM;**1**;Apr 18, 2012;Build 43
;
PRE ; Pre-install
NEW DA,DIK
S DIK="^BQI(90506,",DA=0
F S DA=$O(^BQI(90506,DA)) Q:'DA D ^DIK
S DIK="^BQI(90507.8,",DA=0
F S DA=$O(^BQI(90507.8,DA)) Q:'DA D ^DIK
S DIK="^BQI(90506.5,",DA=0
F S DA=$O(^BQI(90506.5,DA)) Q:'DA D ^DIK
S DIK="^BQI(90508.6,",DA=0
F S DA=$O(^BQI(90508.6,DA)) Q:'DA D ^DIK
S DIK="^BQI(90506.8,",DA=0
F S DA=$O(^BQI(90506.8,DA)) Q:'DA D ^DIK
S DA=0,DIK="^BQI(90509.9,"
F S DA=$O(^BQI(90509.9,DA)) Q:'DA D ^DIK
;
K ^BQI(90506.2,3,6)
Q
;
POS ; Post-Install
;
S $P(^BQI(90508,1,0),U,24)="36M"
; Clean up new style cross-reference
NEW DIK
K ^BQI(90507.7,"AC")
S DIK="^BQI(90507.7," D IXALL^DIK
;
; Update flags
NEW N,CT
S N=0
F S N=$O(^BQIPAT(N)) Q:'N K ^BQIPAT(N,10) S CT=$G(CT)+1 W:CT#500 "."
;
; Update Provider Edit V Form
NEW VN,CN
S VN=$O(^BQI(90506.3,"B","Designated Provider",""))
I VN'="" D
. S CN=$O(^BQI(90506.3,VN,10,"B","Last Modified By",""))
. I CN'="" D
.. S ^BQI(90506.3,VN,10,CN,1)="D^^^^D"
. S CN=$O(^BQI(90506.3,VN,10,"B","Last Modified Date",""))
. I CN'="" D
.. S ^BQI(90506.3,VN,10,CN,1)="T^^^^D"
;
; Update Medication PCC V Form to remove from list
S VN=$O(^BQI(90506.3,"B","Medication",""))
I VN'="" S $P(^BQI(90506.3,VN,0),"^",5)=1
;
NEW BDZ,AIEN
S BDZ=0
F S BDZ=$O(^BQICARE(BDZ)) Q:'BDZ D
. F BQCN=55,75 D
.. S AIEN=$O(^BQICARE(BDZ,11,"B",BQCN,"")) I AIEN="" Q
.. NEW DA,DIK
.. S DA(1)=BDZ,DA=AIEN,DIK="^BQICARE("_DA(1)_",11," D ^DIK
. ;
. NEW NFN,DA,IENS
. S NFN=$O(^BQICARE(BDZ,10,"B",17,"")) I NFN="" Q
. S DA(1)=BDZ,DA=NFN,IENS=$$IENS^DILF(.DA)
. S BQIUPD(90505.09,IENS,.01)=12
. D FILE^DIE("","BQIUPD","ERROR")
;
D DX
;
; Update CMET
S ^BTPW(90621.1,13,0)="V SKIN TEST^9000010.12^.01^^^O^6^9999999.28"
S ^BTPW(90621.2,6,0)="STI^ST",^BTPW(90621.2,"B","STI",6)=""
NEW IEN,EVT,BQIUPD
F IEN=2,14,16 S BQIUPD(90621,IEN_",",.1)=6
D FILE^DIE("","BQIUPD","ERROR")
F EVT=2,14,16 D
. S IEN=""
. F S IEN=$O(^BTPWQ("B",EVT,IEN)) Q:IEN="" S BQIUPD(90629,IEN_",",.13)=6
. F S IEN=$O(^BTPWP("B",EVT,IEN)) Q:IEN="" S BQIUPD(90620,IEN_",",.12)=6
I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
;
NEW DA,DIK
S DA=13,DIK="^BTPW(90621.1," D IX^DIK
;
; Removed the BGP COLO DXS taxonomy
S DA(1)=51,DA=3,DIK="^BTPW(90621,"_DA(1)_",1," D ^DIK
;
; Removed the BGP PAP SMEAR DXS taxonomy
S DA(1)=29,DA=2,DIK="^BTPW(90621,"_DA(1)_",1," D ^DIK
;
; Inactivate the OB/GYN CONSULT event in CMET
S $P(^BTPW(90621,27,0),U,3)=DT,$P(^(0),U,4)="N"
;
NEW TXN,N,VAL,DA,IENS,BQIUPD
S TXN=$O(^ATXAX("B","BTPW COLP IMP NO BX CPTS",""))
I TXN'="" D
. S N=0
. F S N=$O(^ATXAX(TXN,21,N)) Q:'N D
.. S DA(1)=TXN,DA=N,IENS=$$IENS^DILF(.DA)
.. S VAL=$P(^ATXAX(TXN,21,N,0),U,1)
.. I $E(VAL,$L(VAL))'=" " S VAL=VAL_" "
.. S BQIUPD(9002226.02101,IENS,.01)=VAL
.. S BQIUPD(9002226.02101,IENS,.02)=VAL
. D FILE^DIE("","BQIUPD","ERROR")
;
GLS ; Update glossary
NEW GN,GNM,GSN,BQIUPD
S GN=0
F S GN=$O(^BQI(90509.9,GN)) Q:'GN D
. S GNM=$P(^BQI(90509.9,GN,0),U,1)
. S GSN=$O(^BQI(90508.2,"B",GNM,"")) Q:GSN=""
. S BQIUPD(90508.2,GSN_",",1)="@"
. D FILE^DIE("","BQIUPD","ERROR")
. M ^BQI(90508.2,GSN,1)=^BQI(90509.9,GN,1)
;
; Update taxonomies
D EN^BQI23PUC
;
IPC ; Update for IPC4
I $P($G(^BQI(90508,1,"GPRA")),U,1)=2012 D
. I $P(^BGPINDWC(1237,0),U,4)="HED.CWP.1" D
.. S ^BGPINDWC(1237,17)="9^3^Appropriate Testing for Pharyngitis (2-18)^^^O^1"
.. S ^BGPINDWC(1237,18,0)="^^3^3^3120926^"
.. S ^BGPINDWC(1237,18,1,0)="Active Clinical patients who were ages 2-18 years who were diagnosed with "
.. S ^BGPINDWC(1237,18,2,0)="pharyngitis and prescribed an antibiotic during the period six months "
.. S ^BGPINDWC(1237,18,3,0)="(182 days) prior to the Report period."
.. D GCHK^BQIGPUPD(0)
;
; Update IPC measures
D ^BQI23PU4
;
NEW PRV,DA,IEN,IENS,FAC
S PRV=0
F S PRV=$O(^BQIPROV(PRV)) Q:'PRV D
. S IEN=$O(^BQIPROV(PRV,30,"B","2012_2045","")) I IEN="" Q
. S DA(1)=PRV,DA=IEN,IENS=$$IENS^DILF(.DA)
. S BQIUPD(90505.43,IENS,.01)="2012_1966"
S FAC=$O(^BQIFAC(0))
I FAC S IEN=$O(^BQIFAC(FAC,30,"B","2012_2045",""))
I IEN'="" D
. S DA(1)=FAC,DA=IEN,IENS=$$IENS^DILF(.DA)
. S BQIUPD(90505.63,IENS,.01)="2012_1966"
S BQIUPD(90508,"1,",11)="IPC4"
D FILE^DIE("","BQIUPD","ERROR")
;
Q
;
DX ; Check diagnosis code pointers
NEW CN,DN,DXC,DXN
S CN=0
F S CN=$O(^BQI(90507.8,CN)) Q:'CN D
. S DN=0
. F S DN=$O(^BQI(90507.8,CN,10,DN)) Q:'DN D
.. S DXC=$P(^BQI(90507.8,CN,10,DN,0),U,2)_" "
.. S DXN=$$FIND1^DIC(80,"","X",DXC,"BA","","ERROR")
.. I $P(^BQI(90507.8,CN,10,DN,0),U,1)=DXN Q
.. NEW DA,IENS
.. S DA(1)=CN,DA=DN,IENS=$$IENS^DILF(.DA)
.. S BQIUPD(90507.801,IENS,.01)=DXN
. S TN=0
. F S TN=$O(^BQI(90507.8,CN,11,TN)) Q:'TN D
.. S TAX=$P(^BQI(90507.8,CN,11,TN,0),U,1)
.. S VAL=$$STXPT(TAX,"N")
.. NEW DA,IENS
.. S DA(1)=CN,DA=TN,IENS=$$IENS^DILF(.DA)
.. S BQIUPD(90507.811,IENS,.02)=VAL
I $D(BQIUPD) D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
Q
;
STXPT(TXNM,TYP) ; Set taxonomy pointer
;
;Input
; TXNM - Taxonomy name
; TYP - Taxonomy Type (L = LAB, N = Non Lab)
NEW IEN,SIEN,DA,IENS,BQUPD,VALUE,GLB
S VALUE=""
I TYP="L" D
. S IEN=$O(^ATXLAB("B",TXNM,"")),GLB="ATXLAB("
. I IEN="" S TYP="N"
I TYP="N" S IEN=$O(^ATXAX("B",TXNM,"")),GLB="ATXAX("
I IEN="" S VALUE="@"
I IEN'="" S VALUE=IEN_";"_GLB
Q VALUE
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
+2 ;
PRE ; Pre-install
+1 NEW DA,DIK
+2 SET DIK="^BQI(90506,"
SET DA=0
+3 FOR
SET DA=$ORDER(^BQI(90506,DA))
IF 'DA
QUIT
DO ^DIK
+4 SET DIK="^BQI(90507.8,"
SET DA=0
+5 FOR
SET DA=$ORDER(^BQI(90507.8,DA))
IF 'DA
QUIT
DO ^DIK
+6 SET DIK="^BQI(90506.5,"
SET DA=0
+7 FOR
SET DA=$ORDER(^BQI(90506.5,DA))
IF 'DA
QUIT
DO ^DIK
+8 SET DIK="^BQI(90508.6,"
SET DA=0
+9 FOR
SET DA=$ORDER(^BQI(90508.6,DA))
IF 'DA
QUIT
DO ^DIK
+10 SET DIK="^BQI(90506.8,"
SET DA=0
+11 FOR
SET DA=$ORDER(^BQI(90506.8,DA))
IF 'DA
QUIT
DO ^DIK
+12 SET DA=0
SET DIK="^BQI(90509.9,"
+13 FOR
SET DA=$ORDER(^BQI(90509.9,DA))
IF 'DA
QUIT
DO ^DIK
+14 ;
+15 KILL ^BQI(90506.2,3,6)
+16 QUIT
+17 ;
POS ; Post-Install
+1 ;
+2 SET $PIECE(^BQI(90508,1,0),U,24)="36M"
+3 ; Clean up new style cross-reference
+4 NEW DIK
+5 KILL ^BQI(90507.7,"AC")
+6 SET DIK="^BQI(90507.7,"
DO IXALL^DIK
+7 ;
+8 ; Update flags
+9 NEW N,CT
+10 SET N=0
+11 FOR
SET N=$ORDER(^BQIPAT(N))
IF 'N
QUIT
KILL ^BQIPAT(N,10)
SET CT=$GET(CT)+1
IF CT#500
WRITE "."
+12 ;
+13 ; Update Provider Edit V Form
+14 NEW VN,CN
+15 SET VN=$ORDER(^BQI(90506.3,"B","Designated Provider",""))
+16 IF VN'=""
Begin DoDot:1
+17 SET CN=$ORDER(^BQI(90506.3,VN,10,"B","Last Modified By",""))
+18 IF CN'=""
Begin DoDot:2
+19 SET ^BQI(90506.3,VN,10,CN,1)="D^^^^D"
End DoDot:2
+20 SET CN=$ORDER(^BQI(90506.3,VN,10,"B","Last Modified Date",""))
+21 IF CN'=""
Begin DoDot:2
+22 SET ^BQI(90506.3,VN,10,CN,1)="T^^^^D"
End DoDot:2
End DoDot:1
+23 ;
+24 ; Update Medication PCC V Form to remove from list
+25 SET VN=$ORDER(^BQI(90506.3,"B","Medication",""))
+26 IF VN'=""
SET $PIECE(^BQI(90506.3,VN,0),"^",5)=1
+27 ;
+28 NEW BDZ,AIEN
+29 SET BDZ=0
+30 FOR
SET BDZ=$ORDER(^BQICARE(BDZ))
IF 'BDZ
QUIT
Begin DoDot:1
+31 FOR BQCN=55,75
Begin DoDot:2
+32 SET AIEN=$ORDER(^BQICARE(BDZ,11,"B",BQCN,""))
IF AIEN=""
QUIT
+33 NEW DA,DIK
+34 SET DA(1)=BDZ
SET DA=AIEN
SET DIK="^BQICARE("_DA(1)_",11,"
DO ^DIK
End DoDot:2
+35 ;
+36 NEW NFN,DA,IENS
+37 SET NFN=$ORDER(^BQICARE(BDZ,10,"B",17,""))
IF NFN=""
QUIT
+38 SET DA(1)=BDZ
SET DA=NFN
SET IENS=$$IENS^DILF(.DA)
+39 SET BQIUPD(90505.09,IENS,.01)=12
+40 DO FILE^DIE("","BQIUPD","ERROR")
End DoDot:1
+41 ;
+42 DO DX
+43 ;
+44 ; Update CMET
+45 SET ^BTPW(90621.1,13,0)="V SKIN TEST^9000010.12^.01^^^O^6^9999999.28"
+46 SET ^BTPW(90621.2,6,0)="STI^ST"
SET ^BTPW(90621.2,"B","STI",6)=""
+47 NEW IEN,EVT,BQIUPD
+48 FOR IEN=2,14,16
SET BQIUPD(90621,IEN_",",.1)=6
+49 DO FILE^DIE("","BQIUPD","ERROR")
+50 FOR EVT=2,14,16
Begin DoDot:1
+51 SET IEN=""
+52 FOR
SET IEN=$ORDER(^BTPWQ("B",EVT,IEN))
IF IEN=""
QUIT
SET BQIUPD(90629,IEN_",",.13)=6
+53 FOR
SET IEN=$ORDER(^BTPWP("B",EVT,IEN))
IF IEN=""
QUIT
SET BQIUPD(90620,IEN_",",.12)=6
End DoDot:1
+54 IF $DATA(BQIUPD)
DO FILE^DIE("","BQIUPD","ERROR")
+55 ;
+56 NEW DA,DIK
+57 SET DA=13
SET DIK="^BTPW(90621.1,"
DO IX^DIK
+58 ;
+59 ; Removed the BGP COLO DXS taxonomy
+60 SET DA(1)=51
SET DA=3
SET DIK="^BTPW(90621,"_DA(1)_",1,"
DO ^DIK
+61 ;
+62 ; Removed the BGP PAP SMEAR DXS taxonomy
+63 SET DA(1)=29
SET DA=2
SET DIK="^BTPW(90621,"_DA(1)_",1,"
DO ^DIK
+64 ;
+65 ; Inactivate the OB/GYN CONSULT event in CMET
+66 SET $PIECE(^BTPW(90621,27,0),U,3)=DT
SET $PIECE(^(0),U,4)="N"
+67 ;
+68 NEW TXN,N,VAL,DA,IENS,BQIUPD
+69 SET TXN=$ORDER(^ATXAX("B","BTPW COLP IMP NO BX CPTS",""))
+70 IF TXN'=""
Begin DoDot:1
+71 SET N=0
+72 FOR
SET N=$ORDER(^ATXAX(TXN,21,N))
IF 'N
QUIT
Begin DoDot:2
+73 SET DA(1)=TXN
SET DA=N
SET IENS=$$IENS^DILF(.DA)
+74 SET VAL=$PIECE(^ATXAX(TXN,21,N,0),U,1)
+75 IF $EXTRACT(VAL,$LENGTH(VAL))'=" "
SET VAL=VAL_" "
+76 SET BQIUPD(9002226.02101,IENS,.01)=VAL
+77 SET BQIUPD(9002226.02101,IENS,.02)=VAL
End DoDot:2
+78 DO FILE^DIE("","BQIUPD","ERROR")
End DoDot:1
+79 ;
GLS ; Update glossary
+1 NEW GN,GNM,GSN,BQIUPD
+2 SET GN=0
+3 FOR
SET GN=$ORDER(^BQI(90509.9,GN))
IF 'GN
QUIT
Begin DoDot:1
+4 SET GNM=$PIECE(^BQI(90509.9,GN,0),U,1)
+5 SET GSN=$ORDER(^BQI(90508.2,"B",GNM,""))
IF GSN=""
QUIT
+6 SET BQIUPD(90508.2,GSN_",",1)="@"
+7 DO FILE^DIE("","BQIUPD","ERROR")
+8 MERGE ^BQI(90508.2,GSN,1)=^BQI(90509.9,GN,1)
End DoDot:1
+9 ;
+10 ; Update taxonomies
+11 DO EN^BQI23PUC
+12 ;
IPC ; Update for IPC4
+1 IF $PIECE($GET(^BQI(90508,1,"GPRA")),U,1)=2012
Begin DoDot:1
+2 IF $PIECE(^BGPINDWC(1237,0),U,4)="HED.CWP.1"
Begin DoDot:2
+3 SET ^BGPINDWC(1237,17)="9^3^Appropriate Testing for Pharyngitis (2-18)^^^O^1"
+4 SET ^BGPINDWC(1237,18,0)="^^3^3^3120926^"
+5 SET ^BGPINDWC(1237,18,1,0)="Active Clinical patients who were ages 2-18 years who were diagnosed with "
+6 SET ^BGPINDWC(1237,18,2,0)="pharyngitis and prescribed an antibiotic during the period six months "
+7 SET ^BGPINDWC(1237,18,3,0)="(182 days) prior to the Report period."
+8 DO GCHK^BQIGPUPD(0)
End DoDot:2
End DoDot:1
+9 ;
+10 ; Update IPC measures
+11 DO ^BQI23PU4
+12 ;
+13 NEW PRV,DA,IEN,IENS,FAC
+14 SET PRV=0
+15 FOR
SET PRV=$ORDER(^BQIPROV(PRV))
IF 'PRV
QUIT
Begin DoDot:1
+16 SET IEN=$ORDER(^BQIPROV(PRV,30,"B","2012_2045",""))
IF IEN=""
QUIT
+17 SET DA(1)=PRV
SET DA=IEN
SET IENS=$$IENS^DILF(.DA)
+18 SET BQIUPD(90505.43,IENS,.01)="2012_1966"
End DoDot:1
+19 SET FAC=$ORDER(^BQIFAC(0))
+20 IF FAC
SET IEN=$ORDER(^BQIFAC(FAC,30,"B","2012_2045",""))
+21 IF IEN'=""
Begin DoDot:1
+22 SET DA(1)=FAC
SET DA=IEN
SET IENS=$$IENS^DILF(.DA)
+23 SET BQIUPD(90505.63,IENS,.01)="2012_1966"
End DoDot:1
+24 SET BQIUPD(90508,"1,",11)="IPC4"
+25 DO FILE^DIE("","BQIUPD","ERROR")
+26 ;
+27 QUIT
+28 ;
DX ; Check diagnosis code pointers
+1 NEW CN,DN,DXC,DXN
+2 SET CN=0
+3 FOR
SET CN=$ORDER(^BQI(90507.8,CN))
IF 'CN
QUIT
Begin DoDot:1
+4 SET DN=0
+5 FOR
SET DN=$ORDER(^BQI(90507.8,CN,10,DN))
IF 'DN
QUIT
Begin DoDot:2
+6 SET DXC=$PIECE(^BQI(90507.8,CN,10,DN,0),U,2)_" "
+7 SET DXN=$$FIND1^DIC(80,"","X",DXC,"BA","","ERROR")
+8 IF $PIECE(^BQI(90507.8,CN,10,DN,0),U,1)=DXN
QUIT
+9 NEW DA,IENS
+10 SET DA(1)=CN
SET DA=DN
SET IENS=$$IENS^DILF(.DA)
+11 SET BQIUPD(90507.801,IENS,.01)=DXN
End DoDot:2
+12 SET TN=0
+13 FOR
SET TN=$ORDER(^BQI(90507.8,CN,11,TN))
IF 'TN
QUIT
Begin DoDot:2
+14 SET TAX=$PIECE(^BQI(90507.8,CN,11,TN,0),U,1)
+15 SET VAL=$$STXPT(TAX,"N")
+16 NEW DA,IENS
+17 SET DA(1)=CN
SET DA=TN
SET IENS=$$IENS^DILF(.DA)
+18 SET BQIUPD(90507.811,IENS,.02)=VAL
End DoDot:2
End DoDot:1
+19 IF $DATA(BQIUPD)
DO FILE^DIE("","BQIUPD","ERROR")
+20 KILL BQIUPD
+21 QUIT
+22 ;
STXPT(TXNM,TYP) ; Set taxonomy pointer
+1 ;
+2 ;Input
+3 ; TXNM - Taxonomy name
+4 ; TYP - Taxonomy Type (L = LAB, N = Non Lab)
+5 NEW IEN,SIEN,DA,IENS,BQUPD,VALUE,GLB
+6 SET VALUE=""
+7 IF TYP="L"
Begin DoDot:1
+8 SET IEN=$ORDER(^ATXLAB("B",TXNM,""))
SET GLB="ATXLAB("
+9 IF IEN=""
SET TYP="N"
End DoDot:1
+10 IF TYP="N"
SET IEN=$ORDER(^ATXAX("B",TXNM,""))
SET GLB="ATXAX("
+11 IF IEN=""
SET VALUE="@"
+12 IF IEN'=""
SET VALUE=IEN_";"_GLB
+13 QUIT VALUE
