- 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