BJPC2P22.m

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       ;