BJPC2EV3 ; IHS/CMI/LAB - PCC Suite v1.0 patch 2 environment check ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
PRE ;
;
M ;EP - FIX MAMMOGRAM REMINDER
S BJPCX=$O(^APCHSURV("B","MAMMOGRAM",0))
I BJPCX D
.S X=0 F S X=$O(^APCHSURV(BJPCX,11,"B","B",X)) Q:X'=+X D
..K ^APCHSURV(BJPCX,11,"B","B",X),^APCHSURV(BJPCX,11,X)
S BJPCX=$O(^APCHSURV("B","BREAST EXAM",0))
I BJPCX D
.S X=0 F S X=$O(^APCHSURV(BJPCX,11,"B","F",X)) Q:X'=+X D
..I $G(^APCHSURV(BJPCX,11,X,11,1,0))="18Y^100Y^1Y" K ^APCHSURV(BJPCX,11,X),^APCHSURV(BJPCX,11,X,"B","F",X)
S BJPCX=$O(^APCHSURV("B","DIABETES SCREENING",0))
I BJPCX D
.S X=0 F S X=$O(^APCHSURV(BJPCX,11,"B","B",X)) Q:X'=+X D
..I $G(^APCHSURV(BJPCX,11,X,11,1,0))="12Y^99Y^1Y" K ^APCHSURV(BJPCX,11,X),^APCHSURV(BJPCX,11,X,"B","B",X)
Q
POST ;
MOVEFH ;EP - move Family History
D MES^XPDUTL($$CJ^XLFSTR("Converting family hx relationship field to new File.",IOM))
S BJPCX=0 F S BJPCX=$O(^AUPNFH(BJPCX)) Q:BJPCX'=+BJPCX D
.S DFN=$P(^AUPNFH(BJPCX,0),U,2)
.Q:DFN=""
.I $P(^AUPNFH(BJPCX,0),U,12)="" S DIE="^AUPNFH(",DA=BJPCX,DR=".12////"_$P(^AUPNFH(BJPCX,0),U,3) D ^DIE K DA,DR,DIE
.I $P(^AUPNFH(BJPCX,0),U,11)="" D CONVAGE
.Q:$P(^AUPNFH(BJPCX,0),U,9)]"" ;already has a relation
.S X=$P(^AUPNFH(BJPCX,0),U,7)
.I X="" S N=$O(^AUTTRLSH("B","UNKNOWN",0)) G SET
.I '$D(^AUTTRLSH(X,0)) S N=$O(^AUTTRLSH("B","OTHER",0)) G SET
.S X=$P(^AUTTRLSH(X,0),U)
.S N="" F BJPCJ=1:1 S BJPCT=$T(MAPRL+BJPCJ) Q:$P(BJPCT,";;",2)=""!(N]"") D
..S O=$P(BJPCT,";;",2)
..I O=X S N=$P(BJPCT,";;",3)
.I N]"" S N=$O(^AUTTRLSH("B",N,0))
.;I N="" S N=$O(^AUTTRLSH("C",N,0))
.I N="" S N=$O(^AUTTRLSH("B","OTHER",0))
SET .;
.;create family member file entry with this or use existing one and stuff .09 field
.S BJPCY=$O(^AUPNFHR("AA",DFN,N,0))
.I BJPCY D DIE09 Q
.K DIC,DR,DA
.K DD,DO
.S DIC="^AUPNFHR(",DIC(0)="L",X=N,DIC("DR")=".02////"_DFN_";.04////"_$P(^AUPNFH(BJPCX,0),U,6),DIADD=1,DLAYGO=9000014.1
.D FILE^DICN
.I Y=-1 D MES^XPDUTL("Error in CREATING relation for ien "_BJPCX) K DIC,DR,DA,DD,D0,DO,DIADD,DLAYGO Q
.S BJPCY=+Y
.K DIC,DR,DA,DD,D0,DO,DIADD,DLAYGO
.D DIE09
D ^XBFMK
S DIK="^AUPNFH(",DIK(1)=".09^AE" D ENALL^DIK K DIK
;
D HOME^%ZIS,DT^DICRW
;
NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM
KILL ^TMP($J,"BJPCBUL")
D WRITEMSG,GETRECIP
;Change following lines as desired
SUBJECT S XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"
SENDER S XMDUZ="Cimarron Medical Informatics"
S XMTEXT="^TMP($J,""BJPCBUL"",",XMY(1)="",XMY(DUZ)=""
I $E(IOST)="C" W !,"Sending Mailman message to PCC Users."
D ^XMD
KILL ^TMP($J,"BJPCBUL"),BJPCKEY
Q
;
CONVAGE ;
S BJPCN=""
S X=$P(^AUPNFH(BJPCX,0),U,5)
I X="" S BJPCN="U" D DIE11 Q
I X<1 S BJPCN="I" D DIE11 Q
I X<20 S BJPCN="B" D DIE11 Q
I X<30 S BJPCN="2" D DIE11 Q
I X<40 S BJPCN="3" D DIE11 Q
I X<50 S BJPCN="4" D DIE11 Q
I X<60 S BJPCN="5" D DIE11 Q
S BJPCN="6" D DIE11 Q
Q
DIE09 ;
S DA=BJPCX,DIE="^AUPNFH(",DR=".09////"_BJPCY D ^DIE K DIE,DA,DR
I $D(Y) D MES^XPDUTL("Error in updating relation .09 for ien "_BJPCX)
Q
;
DIE11 ;
S DA=BJPCX,DIE="^AUPNFH(",DR=".11////"_BJPCN D ^DIE K DIE,DA,DR
I $D(Y) D MES^XPDUTL("Error in updating AGE .11 for ien "_BJPCX)
Q
;
WRITEMSG ;
S X=$O(^APCLPDES("B","BJPCV1P2",0))
Q:'X
S Y=0 F S Y=$O(^APCLPDES(X,11,Y)) Q:Y'=+Y S ^TMP($J,"BJPCBUL",Y)=^APCLPDES(X,11,Y,0)
Q
;
GETRECIP ;
;
S CTR=0
F BJPCKEY="APCLZMENU","APCDZMENU","APCHZMENU","BDPZMENU","AMQQZMENU"
F S CTR=$O(^XUSEC(BJPCKEY,CTR)) Q:'CTR S Y=CTR S XMY(Y)=""
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
;
MAPRL ;
;;AUNT;;AUNT
;;BROTHER;;BROTHER
;;COUSIN;;COUSIN
;;DAUGHTER;;DAUGHTER (BIOLOGICAL)
;;FATHER;;FATHER (BIOLOGICAL)
;;GRANDFATHER;;GRANDFATHER
;;GRANDMOTHER;;GRANDMOTHER
;;MOTHER;;MOTHER (BIOLOGICAL)
;;NATURAL CHILD;;CHILD (BIOLOGICAL)
;;SISTER;;SISTER
;;SON;;SON (BIOLOGICAL)
;;UNCLE;;UNCLE
;;
BJPC2EV3 ; IHS/CMI/LAB - PCC Suite v1.0 patch 2 environment check ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
PRE ;
+1 ;
M ;EP - FIX MAMMOGRAM REMINDER
+1 SET BJPCX=$ORDER(^APCHSURV("B","MAMMOGRAM",0))
+2 IF BJPCX
Begin DoDot:1
+3 SET X=0
FOR
SET X=$ORDER(^APCHSURV(BJPCX,11,"B","B",X))
IF X'=+X
QUIT
Begin DoDot:2
+4 KILL ^APCHSURV(BJPCX,11,"B","B",X),^APCHSURV(BJPCX,11,X)
End DoDot:2
End DoDot:1
+5 SET BJPCX=$ORDER(^APCHSURV("B","BREAST EXAM",0))
+6 IF BJPCX
Begin DoDot:1
+7 SET X=0
FOR
SET X=$ORDER(^APCHSURV(BJPCX,11,"B","F",X))
IF X'=+X
QUIT
Begin DoDot:2
+8 IF $GET(^APCHSURV(BJPCX,11,X,11,1,0))="18Y^100Y^1Y"
KILL ^APCHSURV(BJPCX,11,X),^APCHSURV(BJPCX,11,X,"B","F",X)
End DoDot:2
End DoDot:1
+9 SET BJPCX=$ORDER(^APCHSURV("B","DIABETES SCREENING",0))
+10 IF BJPCX
Begin DoDot:1
+11 SET X=0
FOR
SET X=$ORDER(^APCHSURV(BJPCX,11,"B","B",X))
IF X'=+X
QUIT
Begin DoDot:2
+12 IF $GET(^APCHSURV(BJPCX,11,X,11,1,0))="12Y^99Y^1Y"
KILL ^APCHSURV(BJPCX,11,X),^APCHSURV(BJPCX,11,X,"B","B",X)
End DoDot:2
End DoDot:1
+13 QUIT
POST ;
MOVEFH ;EP - move Family History
+1 DO MES^XPDUTL($$CJ^XLFSTR("Converting family hx relationship field to new File.",IOM))
+2 SET BJPCX=0
FOR
SET BJPCX=$ORDER(^AUPNFH(BJPCX))
IF BJPCX'=+BJPCX
QUIT
Begin DoDot:1
+3 SET DFN=$PIECE(^AUPNFH(BJPCX,0),U,2)
+4 IF DFN=""
QUIT
+5 IF $PIECE(^AUPNFH(BJPCX,0),U,12)=""
SET DIE="^AUPNFH("
SET DA=BJPCX
SET DR=".12////"_$PIECE(^AUPNFH(BJPCX,0),U,3)
DO ^DIE
KILL DA,DR,DIE
+6 IF $PIECE(^AUPNFH(BJPCX,0),U,11)=""
DO CONVAGE
+7 ;already has a relation
IF $PIECE(^AUPNFH(BJPCX,0),U,9)]""
QUIT
+8 SET X=$PIECE(^AUPNFH(BJPCX,0),U,7)
+9 IF X=""
SET N=$ORDER(^AUTTRLSH("B","UNKNOWN",0))
GOTO SET
+10 IF '$DATA(^AUTTRLSH(X,0))
SET N=$ORDER(^AUTTRLSH("B","OTHER",0))
GOTO SET
+11 SET X=$PIECE(^AUTTRLSH(X,0),U)
+12 SET N=""
FOR BJPCJ=1:1
SET BJPCT=$TEXT(MAPRL+BJPCJ)
IF $PIECE(BJPCT,";;",2)=""!(N]"")
QUIT
Begin DoDot:2
+13 SET O=$PIECE(BJPCT,";;",2)
+14 IF O=X
SET N=$PIECE(BJPCT,";;",3)
End DoDot:2
+15 IF N]""
SET N=$ORDER(^AUTTRLSH("B",N,0))
+16 ;I N="" S N=$O(^AUTTRLSH("C",N,0))
+17 IF N=""
SET N=$ORDER(^AUTTRLSH("B","OTHER",0))
SET ;
+1 ;create family member file entry with this or use existing one and stuff .09 field
+2 SET BJPCY=$ORDER(^AUPNFHR("AA",DFN,N,0))
+3 IF BJPCY
DO DIE09
QUIT
+4 KILL DIC,DR,DA
+5 KILL DD,DO
+6 SET DIC="^AUPNFHR("
SET DIC(0)="L"
SET X=N
SET DIC("DR")=".02////"_DFN_";.04////"_$PIECE(^AUPNFH(BJPCX,0),U,6)
SET DIADD=1
SET DLAYGO=9000014.1
+7 DO FILE^DICN
+8 IF Y=-1
DO MES^XPDUTL("Error in CREATING relation for ien "_BJPCX)
KILL DIC,DR,DA,DD,D0,DO,DIADD,DLAYGO
QUIT
+9 SET BJPCY=+Y
+10 KILL DIC,DR,DA,DD,D0,DO,DIADD,DLAYGO
+11 DO DIE09
End DoDot:1
+12 DO ^XBFMK
+13 SET DIK="^AUPNFH("
SET DIK(1)=".09^AE"
DO ENALL^DIK
KILL DIK
+14 ;
+15 DO HOME^%ZIS
DO DT^DICRW
+16 ;
+17 NEW XMSUB,XMDUZ,XMTEXT,XMY,DIFROM
+18 KILL ^TMP($JOB,"BJPCBUL")
+19 DO WRITEMSG
DO GETRECIP
+20 ;Change following lines as desired
SUBJECT SET XMSUB="* * * IMPORTANT RPMS INFORMATION * * *"
SENDER SET XMDUZ="Cimarron Medical Informatics"
+1 SET XMTEXT="^TMP($J,""BJPCBUL"","
SET XMY(1)=""
SET XMY(DUZ)=""
+2 IF $EXTRACT(IOST)="C"
WRITE !,"Sending Mailman message to PCC Users."
+3 DO ^XMD
+4 KILL ^TMP($JOB,"BJPCBUL"),BJPCKEY
+5 QUIT
+6 ;
CONVAGE ;
+1 SET BJPCN=""
+2 SET X=$PIECE(^AUPNFH(BJPCX,0),U,5)
+3 IF X=""
SET BJPCN="U"
DO DIE11
QUIT
+4 IF X<1
SET BJPCN="I"
DO DIE11
QUIT
+5 IF X<20
SET BJPCN="B"
DO DIE11
QUIT
+6 IF X<30
SET BJPCN="2"
DO DIE11
QUIT
+7 IF X<40
SET BJPCN="3"
DO DIE11
QUIT
+8 IF X<50
SET BJPCN="4"
DO DIE11
QUIT
+9 IF X<60
SET BJPCN="5"
DO DIE11
QUIT
+10 SET BJPCN="6"
DO DIE11
QUIT
+11 QUIT
DIE09 ;
+1 SET DA=BJPCX
SET DIE="^AUPNFH("
SET DR=".09////"_BJPCY
DO ^DIE
KILL DIE,DA,DR
+2 IF $DATA(Y)
DO MES^XPDUTL("Error in updating relation .09 for ien "_BJPCX)
+3 QUIT
+4 ;
DIE11 ;
+1 SET DA=BJPCX
SET DIE="^AUPNFH("
SET DR=".11////"_BJPCN
DO ^DIE
KILL DIE,DA,DR
+2 IF $DATA(Y)
DO MES^XPDUTL("Error in updating AGE .11 for ien "_BJPCX)
+3 QUIT
+4 ;
WRITEMSG ;
+1 SET X=$ORDER(^APCLPDES("B","BJPCV1P2",0))
+2 IF 'X
QUIT
+3 SET Y=0
FOR
SET Y=$ORDER(^APCLPDES(X,11,Y))
IF Y'=+Y
QUIT
SET ^TMP($JOB,"BJPCBUL",Y)=^APCLPDES(X,11,Y,0)
+4 QUIT
+5 ;
GETRECIP ;
+1 ;
+2 SET CTR=0
+3 FOR BJPCKEY="APCLZMENU","APCDZMENU","APCHZMENU","BDPZMENU","AMQQZMENU"
+4 FOR
SET CTR=$ORDER(^XUSEC(BJPCKEY,CTR))
IF 'CTR
QUIT
SET Y=CTR
SET XMY(Y)=""
+5 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
+6 ;
MAPRL ;
+1 ;;AUNT;;AUNT
+2 ;;BROTHER;;BROTHER
+3 ;;COUSIN;;COUSIN
+4 ;;DAUGHTER;;DAUGHTER (BIOLOGICAL)
+5 ;;FATHER;;FATHER (BIOLOGICAL)
+6 ;;GRANDFATHER;;GRANDFATHER
+7 ;;GRANDMOTHER;;GRANDMOTHER
+8 ;;MOTHER;;MOTHER (BIOLOGICAL)
+9 ;;NATURAL CHILD;;CHILD (BIOLOGICAL)
+10 ;;SISTER;;SISTER
+11 ;;SON;;SON (BIOLOGICAL)
+12 ;;UNCLE;;UNCLE
+13 ;;
