BCHPOST.m

BCHPOST ; IHS/CMI/LAB - POST INIT ROUTINE ; 

 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 ;

ENV ;EP;

 ; The following line prevents the "Disable Options..." and "Move

 ; Routines..." questions from being asked during the install.

 F X="XPM1","XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0

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

 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("ACM*2.0*6") D SORRY(2)

 Q

PRE ;

 S DA=0 F  S DA=$O(^BCHSORT(DA)) Q:DA'=+DA  S DIK="^BCHSORT(" D ^DIK

 S DA=0 F  S DA=$O(^BCHTCNAR(DA)) Q:DA'=+DA  S DIK="^BCHTCNAR(" D ^DIK

SC S DA=$O(^BCHTSERV("B","OTHER EDUCATION",0))

 I DA S DIE="^BCHTSERV(",DR=".01///PROVIDE STAFF TRAINING;.03///ST" D ^DIE K DA,DR,DIE

 ;S DIU=90002.01,DIU(0)="S" D EN^DIU2

 Q

PWH ;create CHR type PWH

 NEW BCHX,BCHC,BCHHTX,BCHTEXT,BCHFDA,BCHER,BCHERRR,FL,BCHIENS

 S X="CHR PWH",DIC="^APCHPWHT(",DIC(0)="L",DIADD=1,DLAYGO=9001026 D FILE^DICN K DIADD,DLAYGO,DIC

 I Y=-1 D MES^XPDUTL("UNABLE TO CREATE PWH TYPE - NOTIFY PROGRAMMER") Q

 S BCHY=+Y

 S BCHTEXT="PWHC" F BCHX=1:1 S BCHTX=$P($T(@BCHTEXT+BCHX),";;",2,4) Q:BCHTX=""  D

 .S BCHO=$P(BCHTX,";;",1),BCHC=$P(BCHTX,";;",2)

 . S DA(1)=BCHY,X=BCHO,DINUM=X

 . S DIC="^APCHPWHT("_DA(1)_",1,"

 . S DIC(0)="L"

 . S DIC("P")=$P(^DD(9001026,1,0),U,2)

 . S DIC("DR")=".03///"_$P(BCHTX,";;",3)_";1////"_$O(^APCHPWHC("B",BCHC,0))

 . D ^DIC

 . I Y=-1 D MES^XPDUTL("ERROR CREATING PWH - NOTIFY PROGRAMMER") Q

 . Q

 K DINUM,DIC,DIADD,DLAYGO

 Q

POST ;

 ;

 I '$O(^APCHPWHT("B","CHR PWH",0)) D PWH

 ;move referral data into the multiples

 S BCHR=0 F  S BCHR=$O(^BCHR(BCHR)) Q:BCHR'=+BCHR  D

 .Q:'$D(^BCHR(BCHR,0))

 .S BCHRT=$P(^BCHR(BCHR,0),U,7)

 .I BCHRT D

 ..Q:$D(^BCHR(BCHR,41,0))  ;already has multiple

 ..S ^BCHR(BCHR,41,0)="^90002.141PA^1^1"

 ..S ^BCHR(BCHR,41,1,0)=BCHRT

 ..S ^BCHR(BCHR,41,"B",BCHRT,1)=""

 .S BCHRT=$P(^BCHR(BCHR,0),U,8)

 .I BCHRT D

 ..Q:$D(^BCHR(BCHR,42,0))  ;already has multiple

 ..S ^BCHR(BCHR,42,0)="^90002.142PA^1^1"

 ..S ^BCHR(BCHR,42,1,0)=BCHRT

 ..S ^BCHR(BCHR,42,"B",BCHRT,1)=""

 ;K ^DD(90002.01,0,"ID")  

 ; REINDEX C XREF OF CHR TEMP GROUP FILE

 S DIK="^BCHGROUP(" D IXALL^DIK

 ;set up zish send parameters

 D ZISH

 Q

 ;

 ;

ZISH ;create entry in ZISH SEND PARAMETERS file

 D ^XBFMK K DIADD,DLAYGO,DIC,DD,D0,DO

 ;Q:$D(^%ZIB(9888888.93,"B","BCHR AUTO SEND"))

 S APCLY=0 F  S APCLY=$O(^%ZIB(9888888.93,"B","BCHR AUTO SEND",0)) Q:APCLY'=+APCLY  D

 .I APCLY S DA=APCLY,DIK="^%ZIB(9888888.93," D ^DIK K DA,DIK

 S X="BCHR AUTO SEND",DIC(0)="L",DIC="^%ZIB(9888888.93," D FILE^DICN

 I Y=-1 W !!,"error creating ZISH SEND PARAMETERS entry" Q

 S DA=+Y,DIE="^%ZIB(9888888.93,",DR=".02///QUOVADX-IE.IHS.GOV;.03///ihpesusr;.04///g2dwy66b;.06///-u;.07///B;.08///sendto"

 D ^DIE

 I $D(Y) W !!,"error updating ZISH SEND PARAMETERS entry" Q

 Q

 ;

INSTALLD(BCHSTAL) ;EP - Determine if patch BCHSTAL was installed, where

 ; BCHSTAL is the name of the INSTALL.  E.g "AG*6.0*11".

 NEW BCHY,DIC,X,Y

 S X=$P(BCHSTAL,"*",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(BCHSTAL,"*",2)

 D ^DIC

 I Y<1 D IMES Q 0

 S DIC=DIC_+Y_",""PAH"",",X=$P(BCHSTAL,"*",3)

 D ^DIC

 S BCHY=Y

 D IMES

 Q $S(BCHY<1:0,1:1)

IMES ;

 D MES^XPDUTL($$CJ^XLFSTR("Patch """_BCHSTAL_""" 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

PWHC ;;

 ;;10;;ACTIVITY LEVEL

 ;;20;;ALLERGIES;;A

 ;;40;;BLOOD PRESSURE

 ;;70;;CANCER SCREENING

 ;;80;;CHOLESTEROL

 ;;90;;DIABETES CARE

 ;;50;;HEIGHT/WEIGHT/BMI

 ;;60;;IMMUNIZATIONS DUE

 ;;30;;MEDICATIONS (ACTIVE ONLY)

 ;;100;;PATIENT GOALS

BCHPOST   ; IHS/CMI/LAB - POST INIT ROUTINE ; 

 +1       ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 +2       ;

ENV       ;EP;

 +1       ; The following line prevents the "Disable Options..." and "Move

 +2       ; Routines..." questions from being asked during the install.

 +3        FOR X="XPM1","XPO1","XPZ1","XPZ2","XPI1"

               SET XPDDIQ(X)=0

 +4        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

 +5       IF '$TEST

               DO MES^XPDUTL($$CJ^XLFSTR("Requires Kernel Version 8.0....Present.",80))

 +6        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

 +7       IF '$TEST

               DO MES^XPDUTL($$CJ^XLFSTR("Requires Fileman v22....Present.",80))

 +8       ;I '$$INSTALLD("ACM*2.0*6") D SORRY(2)

 +9        QUIT 

PRE       ;

 +1        SET DA=0

           FOR 

               SET DA=$ORDER(^BCHSORT(DA))

               IF DA'=+DA

                   QUIT 

               SET DIK="^BCHSORT("

               DO ^DIK

 +2        SET DA=0

           FOR 

               SET DA=$ORDER(^BCHTCNAR(DA))

               IF DA'=+DA

                   QUIT 

               SET DIK="^BCHTCNAR("

               DO ^DIK

SC         SET DA=$ORDER(^BCHTSERV("B","OTHER EDUCATION",0))

 +1        IF DA

               SET DIE="^BCHTSERV("

               SET DR=".01///PROVIDE STAFF TRAINING;.03///ST"

               DO ^DIE

               KILL DA,DR,DIE

 +2       ;S DIU=90002.01,DIU(0)="S" D EN^DIU2

 +3        QUIT 

PWH       ;create CHR type PWH

 +1        NEW BCHX,BCHC,BCHHTX,BCHTEXT,BCHFDA,BCHER,BCHERRR,FL,BCHIENS

 +2        SET X="CHR PWH"

           SET DIC="^APCHPWHT("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9001026

           DO FILE^DICN

           KILL DIADD,DLAYGO,DIC

 +3        IF Y=-1

               DO MES^XPDUTL("UNABLE TO CREATE PWH TYPE - NOTIFY PROGRAMMER")

               QUIT 

 +4        SET BCHY=+Y

 +5        SET BCHTEXT="PWHC"

           FOR BCHX=1:1

               SET BCHTX=$PIECE($TEXT(@BCHTEXT+BCHX),";;",2,4)

               IF BCHTX=""

                   QUIT 

               Begin DoDot:1

 +6                SET BCHO=$PIECE(BCHTX,";;",1)

                   SET BCHC=$PIECE(BCHTX,";;",2)

 +7                SET DA(1)=BCHY

                   SET X=BCHO

                   SET DINUM=X

 +8                SET DIC="^APCHPWHT("_DA(1)_",1,"

 +9                SET DIC(0)="L"

 +10               SET DIC("P")=$PIECE(^DD(9001026,1,0),U,2)

 +11               SET DIC("DR")=".03///"_$PIECE(BCHTX,";;",3)_";1////"_$ORDER(^APCHPWHC("B",BCHC,0))

 +12               DO ^DIC

 +13               IF Y=-1

                       DO MES^XPDUTL("ERROR CREATING PWH - NOTIFY PROGRAMMER")

                       QUIT 

 +14               QUIT 

               End DoDot:1

 +15       KILL DINUM,DIC,DIADD,DLAYGO

 +16       QUIT 

POST      ;

 +1       ;

 +2        IF '$ORDER(^APCHPWHT("B","CHR PWH",0))

               DO PWH

 +3       ;move referral data into the multiples

 +4        SET BCHR=0

           FOR 

               SET BCHR=$ORDER(^BCHR(BCHR))

               IF BCHR'=+BCHR

                   QUIT 

               Begin DoDot:1

 +5                IF '$DATA(^BCHR(BCHR,0))

                       QUIT 

 +6                SET BCHRT=$PIECE(^BCHR(BCHR,0),U,7)

 +7                IF BCHRT

                       Begin DoDot:2

 +8       ;already has multiple

                           IF $DATA(^BCHR(BCHR,41,0))

                               QUIT 

 +9                        SET ^BCHR(BCHR,41,0)="^90002.141PA^1^1"

 +10                       SET ^BCHR(BCHR,41,1,0)=BCHRT

 +11                       SET ^BCHR(BCHR,41,"B",BCHRT,1)=""

                       End DoDot:2

 +12               SET BCHRT=$PIECE(^BCHR(BCHR,0),U,8)

 +13               IF BCHRT

                       Begin DoDot:2

 +14      ;already has multiple

                           IF $DATA(^BCHR(BCHR,42,0))

                               QUIT 

 +15                       SET ^BCHR(BCHR,42,0)="^90002.142PA^1^1"

 +16                       SET ^BCHR(BCHR,42,1,0)=BCHRT

 +17                       SET ^BCHR(BCHR,42,"B",BCHRT,1)=""

                       End DoDot:2

               End DoDot:1

 +18      ;K ^DD(90002.01,0,"ID")  

 +19      ; REINDEX C XREF OF CHR TEMP GROUP FILE

 +20       SET DIK="^BCHGROUP("

           DO IXALL^DIK

 +21      ;set up zish send parameters

 +22       DO ZISH

 +23       QUIT 

 +24      ;

 +25      ;

ZISH      ;create entry in ZISH SEND PARAMETERS file

 +1        DO ^XBFMK

           KILL DIADD,DLAYGO,DIC,DD,D0,DO

 +2       ;Q:$D(^%ZIB(9888888.93,"B","BCHR AUTO SEND"))

 +3        SET APCLY=0

           FOR 

               SET APCLY=$ORDER(^%ZIB(9888888.93,"B","BCHR AUTO SEND",0))

               IF APCLY'=+APCLY

                   QUIT 

               Begin DoDot:1

 +4                IF APCLY

                       SET DA=APCLY

                       SET DIK="^%ZIB(9888888.93,"

                       DO ^DIK

                       KILL DA,DIK

               End DoDot:1

 +5        SET X="BCHR AUTO SEND"

           SET DIC(0)="L"

           SET DIC="^%ZIB(9888888.93,"

           DO FILE^DICN

 +6        IF Y=-1

               WRITE !!,"error creating ZISH SEND PARAMETERS entry"

               QUIT 

 +7        SET DA=+Y

           SET DIE="^%ZIB(9888888.93,"

           SET DR=".02///QUOVADX-IE.IHS.GOV;.03///ihpesusr;.04///g2dwy66b;.06///-u;.07///B;.08///sendto"

 +8        DO ^DIE

 +9        IF $DATA(Y)

               WRITE !!,"error updating ZISH SEND PARAMETERS entry"

               QUIT 

 +10       QUIT 

 +11      ;

INSTALLD(BCHSTAL) ;EP - Determine if patch BCHSTAL was installed, where

 +1       ; BCHSTAL is the name of the INSTALL.  E.g "AG*6.0*11".

 +2        NEW BCHY,DIC,X,Y

 +3        SET X=$PIECE(BCHSTAL,"*",1)

 +4        SET DIC="^DIC(9.4,"

           SET DIC(0)="FM"

           SET D="C"

 +5        DO IX^DIC

 +6        IF Y<1

               DO IMES

               QUIT 0

 +7        SET DIC=DIC_+Y_",22,"

           SET X=$PIECE(BCHSTAL,"*",2)

 +8        DO ^DIC

 +9        IF Y<1

               DO IMES

               QUIT 0

 +10       SET DIC=DIC_+Y_",""PAH"","

           SET X=$PIECE(BCHSTAL,"*",3)

 +11       DO ^DIC

 +12       SET BCHY=Y

 +13       DO IMES

 +14       QUIT $SELECT(BCHY<1:0,1:1)

IMES      ;

 +1        DO MES^XPDUTL($$CJ^XLFSTR("Patch """_BCHSTAL_""" 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 

PWHC      ;;

 +1       ;;10;;ACTIVITY LEVEL

 +2       ;;20;;ALLERGIES;;A

 +3       ;;40;;BLOOD PRESSURE

 +4       ;;70;;CANCER SCREENING

 +5       ;;80;;CHOLESTEROL

 +6       ;;90;;DIABETES CARE

 +7       ;;50;;HEIGHT/WEIGHT/BMI

 +8       ;;60;;IMMUNIZATIONS DUE

 +9       ;;30;;MEDICATIONS (ACTIVE ONLY)

 +10      ;;100;;PATIENT GOALS