BJPC2P16.m

BJPC2P16 ; IHS/CMI/LAB - PCC Suite v2.0 P15 ;   

 ;;2.0;IHS PCC SUITE;**16**;MAY 14, 2009;Build 9

 ;

 ;

 ; 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))

 ;BJPC 2.0 PATCH 13

 I '$$INSTALLD("BJPC*2.0*15") D MES^XPDUTL($$CJ^XLFSTR("Requires bjpc V2.0 patch 15.  Not installed.",80)) D SORRY(2)

 ;I '$$INSTALLD("ATX*5.1*13") D MES^XPDUTL($$CJ^XLFSTR("Requires atx (taxonomy) v5.1 patch 13.  Not installed.",80)) D SORRY(2)

 ;

 Q

 ;

PRE ;

 K ^APCHTMP("HMR STATUS")

 S X=0 F  S X=$O(^APCHSURV(X)) Q:X'=+X  S ^APCHTMP("HMR STATUS",X)=$P(^APCHSURV(X,0),U)_U_$P(^APCHSURV(X,0),U,3)

 Q

POST ;

 ;CR# 05990

 S DA=$O(^AUTTMSR("B","AG",0)) I DA S ^AUTTMSR(DA,11,1,0)="Enter Abdominal Girth.  Must be in the range 0-250. Up to 2 decimal ",^AUTTMSR(DA,11,2,0)="digits. e.g. 38.5 or 40 or 39.25"

 K ^AUPNPROB("ASLT")

 K ^AUPNPROB("ALST")

 ;K ^DD(9000011,0,"IX","ALST",9000011,80001)

 ;K ^DD(9000011,0,"IX","ALSTA",9000011,.22)

 S DIK="^AUPNPROB(",DIK(1)=".22" D ENALL^DIK

 ;HMR STATUS

 S APCHX=0 F  S APCHX=$O(^APCHTMP("HMR STATUS",APCHX)) Q:APCHX'=+APCHX  D

 .S X=$P(^APCHTMP("HMR STATUS",APCHX),U),APCHS=$P(^APCHTMP("HMR STATUS",APCHX),U,2)  ;,DIC="^APCHSURV(",DIC(0)="M" D ^DIC

 .;I Y=-1 W !!,"could not update status on ",X," hmr" Q

 .Q:'$D(^APCHSURV(APCHX,0))

 .I $P(^APCHSURV(APCHX,0),U,3)'="D" S $P(^APCHSURV(APCHX,0),U,3)=APCHS

 K ^APCHTMP("HMR STATUS")

 K APCHX,APCHS

 S X=$$ADD^XPDMENU("APCDSUPER","APCD UPDATE DEFAULT STATUS","PLST")

 I 'X W !,"Attempt to add APCD UPDATE DEFAULT STATUS option failed.." H 3

 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

BJPC2P16  ; IHS/CMI/LAB - PCC Suite v2.0 P15 ;   

 +1       ;;2.0;IHS PCC SUITE;**16**;MAY 14, 2009;Build 9

 +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      ;BJPC 2.0 PATCH 13

 +14       IF '$$INSTALLD("BJPC*2.0*15")

               DO MES^XPDUTL($$CJ^XLFSTR("Requires bjpc V2.0 patch 15.  Not installed.",80))

               DO SORRY(2)

 +15      ;I '$$INSTALLD("ATX*5.1*13") D MES^XPDUTL($$CJ^XLFSTR("Requires atx (taxonomy) v5.1 patch 13.  Not installed.",80)) D SORRY(2)

 +16      ;

 +17       QUIT 

 +18      ;

PRE       ;

 +1        KILL ^APCHTMP("HMR STATUS")

 +2        SET X=0

           FOR 

               SET X=$ORDER(^APCHSURV(X))

               IF X'=+X

                   QUIT 

               SET ^APCHTMP("HMR STATUS",X)=$PIECE(^APCHSURV(X,0),U)_U_$PIECE(^APCHSURV(X,0),U,3)

 +3        QUIT 

POST      ;

 +1       ;CR# 05990

 +2        SET DA=$ORDER(^AUTTMSR("B","AG",0))

           IF DA

               SET ^AUTTMSR(DA,11,1,0)="Enter Abdominal Girth.  Must be in the range 0-250. Up to 2 decimal "

               SET ^AUTTMSR(DA,11,2,0)="digits. e.g. 38.5 or 40 or 39.25"

 +3        KILL ^AUPNPROB("ASLT")

 +4        KILL ^AUPNPROB("ALST")

 +5       ;K ^DD(9000011,0,"IX","ALST",9000011,80001)

 +6       ;K ^DD(9000011,0,"IX","ALSTA",9000011,.22)

 +7        SET DIK="^AUPNPROB("

           SET DIK(1)=".22"

           DO ENALL^DIK

 +8       ;HMR STATUS

 +9        SET APCHX=0

           FOR 

               SET APCHX=$ORDER(^APCHTMP("HMR STATUS",APCHX))

               IF APCHX'=+APCHX

                   QUIT 

               Begin DoDot:1

 +10      ;,DIC="^APCHSURV(",DIC(0)="M" D ^DIC

                   SET X=$PIECE(^APCHTMP("HMR STATUS",APCHX),U)

                   SET APCHS=$PIECE(^APCHTMP("HMR STATUS",APCHX),U,2)

 +11      ;I Y=-1 W !!,"could not update status on ",X," hmr" Q

 +12               IF '$DATA(^APCHSURV(APCHX,0))

                       QUIT 

 +13               IF $PIECE(^APCHSURV(APCHX,0),U,3)'="D"

                       SET $PIECE(^APCHSURV(APCHX,0),U,3)=APCHS

               End DoDot:1

 +14       KILL ^APCHTMP("HMR STATUS")

 +15       KILL APCHX,APCHS

 +16       SET X=$$ADD^XPDMENU("APCDSUPER","APCD UPDATE DEFAULT STATUS","PLST")

 +17       IF 'X

               WRITE !,"Attempt to add APCD UPDATE DEFAULT STATUS option failed.."

               HANG 3

 +18       QUIT 

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