Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BJPC2EV3

BJPC2EV3.m

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