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
