BJPC2P22 ; IHS/CMI/LAB - PCC Suite v2.0
;;2.0;IHS PCC SUITE;**22**;MAY 14, 2009;Build 6
;
;
; The following line prevents the "Disable Options..." and "Move Routines..." questions from being asked during the install.
I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
;KERNEL
I +$$VERSION^XPDUTL("XU")<8 D MES^XPDUTL($$CJ^XLFSTR("Version 8.0 of KERNEL is required. Not installed",80)) D SORRY(2) I 1
E D MES^XPDUTL($$CJ^XLFSTR("Requires Kernel Version 8.0....Present.",80))
;FILEMAN
I +$$VERSION^XPDUTL("DI")<22 D MES^XPDUTL($$CJ^XLFSTR("Version 22.0 of FILEMAN is required. Not installed.",80)) D SORRY(2) I 1
E D MES^XPDUTL($$CJ^XLFSTR("Requires Fileman v22....Present.",80))
I '$$INSTALLD("BJPC*2.0*21") D MES^XPDUTL($$CJ^XLFSTR("Requires bjpc V2.0 patch 21. Not installed.",80)) D SORRY(2)
I '$$INSTALLD("BCQM*1.0*4") D MES^XPDUTL($$CJ^XLFSTR("Requires BCQM V1.0 patch 4. Not installed.",80)) D SORRY(2)
;
Q
;
PRE ;
Q
POST ;
;kill and reindex "AA" on patent refusals for service
D MES^XPDUTL($$CJ^XLFSTR("Reindexing AA index on Patient Refusals file",80))
K ^AUPNPREF("AA")
S DIK="^AUPNPREF(",DIK(1)=".02^AA" D ENALL^DIK K DIK
D CPTPROC
Q
CPTPROC ;
;backfill snomed for updated/reviewed/exam and meas for 1 year
S ZTIO=""
S ZTRTN="CPTPROC1^BJPC2P22",ZTDTH=$$NOW^XLFDT,ZTDESC="BACKFILL V CPT/PROCEDURE SNOMED" D ^%ZTLOAD
Q
CPTPROC1 ;
;D MES^XPDUTL($$CJ^XLFSTR("Backfilling SNOMED in V CPT and V Procedure..this may take up to 10 minutes..",80))
S BJPCD=$$FMADD^XLFDT(DT,-(2*366)) ;go back about 2 year
I BJPCD>3161231 S BJPCD=3161231.9999
F S BJPCD=$O(^AUPNVSIT("B",BJPCD)) Q:BJPCD="" D
.S BJPCV=0 F S BJPCV=$O(^AUPNVSIT("B",BJPCD,BJPCV)) Q:BJPCV'=+BJPCV D
..S BJPCX=0
..F S BJPCX=$O(^AUPNVCPT("AD",BJPCV,BJPCX)) Q:BJPCX'=+BJPCX D
...Q:'$D(^AUPNVCPT(BJPCX,0))
...S DA=BJPCX
...D CPT^AUPNMAP
...Q
..S BJPCX=0
..F S BJPCX=$O(^AUPNVPRC("AD",BJPCV,BJPCX)) Q:BJPCX'=+BJPCX D
...Q:'$D(^AUPNVPRC(BJPCX,0))
...S DA=BJPCX
...D PRC^AUPNMAP
..S BJPCX=0
..F S BJPCX=$O(^AUPNVXAM("AD",BJPCV,BJPCX)) Q:BJPCX'=+BJPCX D
...Q:'$D(^AUPNVXAM(BJPCX,0))
...S DA=BJPCX
...D EXAM^AUPNMAP
Q
;
INSTALLD(BJPCSTAL) ;EP - Determine if patch BJPCSTAL was installed, where
; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
;
NEW BJPCY,DIC,X,Y
S X=$P(BJPCSTAL,"*",1)
S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
D IX^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",22,",X=$P(BJPCSTAL,"*",2)
D ^DIC
I Y<1 D IMES Q 0
S DIC=DIC_+Y_",""PAH"",",X=$P(BJPCSTAL,"*",3)
D ^DIC
S BJPCY=Y
D IMES
Q $S(BJPCY<1:0,1:1)
IMES ;
D MES^XPDUTL($$CJ^XLFSTR("Patch """_BJPCSTAL_""" is"_$S(Y<1:" *NOT*",1:"")_" installed.",IOM))
Q
SORRY(X) ;
KILL DIFQ
I X=3 S XPDQUIT=2 Q
S XPDQUIT=X
W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
Q
;
BJPC2P22 ; IHS/CMI/LAB - PCC Suite v2.0
+1 ;;2.0;IHS PCC SUITE;**22**;MAY 14, 2009;Build 6
+2 ;
+3 ;
+4 ; The following line prevents the "Disable Options..." and "Move Routines..." questions from being asked during the install.
+5 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+6 FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
+7 ;KERNEL
+8 IF +$$VERSION^XPDUTL("XU")<8
DO MES^XPDUTL($$CJ^XLFSTR("Version 8.0 of KERNEL is required. Not installed",80))
DO SORRY(2)
IF 1
+9 IF '$TEST
DO MES^XPDUTL($$CJ^XLFSTR("Requires Kernel Version 8.0....Present.",80))
+10 ;FILEMAN
+11 IF +$$VERSION^XPDUTL("DI")<22
DO MES^XPDUTL($$CJ^XLFSTR("Version 22.0 of FILEMAN is required. Not installed.",80))
DO SORRY(2)
IF 1
+12 IF '$TEST
DO MES^XPDUTL($$CJ^XLFSTR("Requires Fileman v22....Present.",80))
+13 IF '$$INSTALLD("BJPC*2.0*21")
DO MES^XPDUTL($$CJ^XLFSTR("Requires bjpc V2.0 patch 21. Not installed.",80))
DO SORRY(2)
+14 IF '$$INSTALLD("BCQM*1.0*4")
DO MES^XPDUTL($$CJ^XLFSTR("Requires BCQM V1.0 patch 4. Not installed.",80))
DO SORRY(2)
+15 ;
+16 QUIT
+17 ;
PRE ;
+1 QUIT
POST ;
+1 ;kill and reindex "AA" on patent refusals for service
+2 DO MES^XPDUTL($$CJ^XLFSTR("Reindexing AA index on Patient Refusals file",80))
+3 KILL ^AUPNPREF("AA")
+4 SET DIK="^AUPNPREF("
SET DIK(1)=".02^AA"
DO ENALL^DIK
KILL DIK
+5 DO CPTPROC
+6 QUIT
CPTPROC ;
+1 ;backfill snomed for updated/reviewed/exam and meas for 1 year
+2 SET ZTIO=""
+3 SET ZTRTN="CPTPROC1^BJPC2P22"
SET ZTDTH=$$NOW^XLFDT
SET ZTDESC="BACKFILL V CPT/PROCEDURE SNOMED"
DO ^%ZTLOAD
+4 QUIT
CPTPROC1 ;
+1 ;D MES^XPDUTL($$CJ^XLFSTR("Backfilling SNOMED in V CPT and V Procedure..this may take up to 10 minutes..",80))
+2 ;go back about 2 year
SET BJPCD=$$FMADD^XLFDT(DT,-(2*366))
+3 IF BJPCD>3161231
SET BJPCD=3161231.9999
+4 FOR
SET BJPCD=$ORDER(^AUPNVSIT("B",BJPCD))
IF BJPCD=""
QUIT
Begin DoDot:1
+5 SET BJPCV=0
FOR
SET BJPCV=$ORDER(^AUPNVSIT("B",BJPCD,BJPCV))
IF BJPCV'=+BJPCV
QUIT
Begin DoDot:2
+6 SET BJPCX=0
+7 FOR
SET BJPCX=$ORDER(^AUPNVCPT("AD",BJPCV,BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVCPT(BJPCX,0))
QUIT
+9 SET DA=BJPCX
+10 DO CPT^AUPNMAP
+11 QUIT
End DoDot:3
+12 SET BJPCX=0
+13 FOR
SET BJPCX=$ORDER(^AUPNVPRC("AD",BJPCV,BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:3
+14 IF '$DATA(^AUPNVPRC(BJPCX,0))
QUIT
+15 SET DA=BJPCX
+16 DO PRC^AUPNMAP
End DoDot:3
+17 SET BJPCX=0
+18 FOR
SET BJPCX=$ORDER(^AUPNVXAM("AD",BJPCV,BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:3
+19 IF '$DATA(^AUPNVXAM(BJPCX,0))
QUIT
+20 SET DA=BJPCX
+21 DO EXAM^AUPNMAP
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
INSTALLD(BJPCSTAL) ;EP - Determine if patch BJPCSTAL was installed, where
+1 ; APCLSTAL is the name of the INSTALL. E.g "AG*6.0*11".
+2 ;
+3 NEW BJPCY,DIC,X,Y
+4 SET X=$PIECE(BJPCSTAL,"*",1)
+5 SET DIC="^DIC(9.4,"
SET DIC(0)="FM"
SET D="C"
+6 DO IX^DIC
+7 IF Y<1
DO IMES
QUIT 0
+8 SET DIC=DIC_+Y_",22,"
SET X=$PIECE(BJPCSTAL,"*",2)
+9 DO ^DIC
+10 IF Y<1
DO IMES
QUIT 0
+11 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(BJPCSTAL,"*",3)
+12 DO ^DIC
+13 SET BJPCY=Y
+14 DO IMES
+15 QUIT $SELECT(BJPCY<1:0,1:1)
IMES ;
+1 DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BJPCSTAL_""" is"_$SELECT(Y<1:" *NOT*",1:"")_" installed.",IOM))
+2 QUIT
SORRY(X) ;
+1 KILL DIFQ
+2 IF X=3
SET XPDQUIT=2
QUIT
+3 SET XPDQUIT=X
+4 WRITE *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
+5 QUIT
+6 ;
