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

BMC4P0.m

Go to the documentation of this file. 
  1. BMC4P0 ;IHS/ITSC/FCJ - BMC 4.0 INSTALL 2 OF 2;       
  1.  ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
  1.  ;PRE AND POST ROUTINE FOR INSTALL
  1.  ;
  1. PRE ;EP - From KIDS.
  1.  I BMCNEW Q
  1.  ; ---Save and remove dd audit settings.
  1.  I $$NEWCP^XPDUTL("PRE1","AUDS^BMC4P")
  1.  ; ---Delete Med HX, BO, and discharge notes fr RCIS Referral file
  1.  S %="DELC^BMC4P"
  1.  I $$NEWCP^XPDUTL("PRE2-"_%,%)
  1.  ; ---Delete Fields: Med HX,BO,Discharge Comments fr RCIS Ref file 
  1.  S %="DELFLD^BMC4P"
  1.  I $$NEWCP^XPDUTL("PRE3-"_%,%)
  1.  ; ---Reset Suffix for Sec Ref
  1.  S %="RESUF^BMC4P"
  1.  I $$NEWCP^XPDUTL("PRE4-"_%,%)
  1.  Q
  1.  ;
  1. POST ;EP - From KIDS.
  1.  ;TEST FOR NEW INSTALL
  1.  I BMCNEW D  G SNDM
  1.  .S %="START^BMCPOST"
  1.  .I $$NEWCP^XPDUTL("POS1-"_%,%)
  1.  ;
  1.  ; ---update RCIS Referral with Secondary Ref
  1.  S %="V4SEC^BMC4P0"
  1.  I $$NEWCP^XPDUTL("POS2-"_%,%)
  1.  ;
  1.  ; --- Update the closed status from "C2" to "X"
  1.  S %="V4CLS^BMC4P0"
  1.  I $$NEWCP^XPDUTL("POS3-"_%,%)
  1.  ;
  1.  ; --- Remove CHS Denial report menu option
  1.  S %="V4OPT^BMC4P0"
  1.  I $$NEWCP^XPDUTL("POS4-"_%,%)
  1.  ;
  1.  ; --- Restore dd audit settings.
  1.  S %="AUDR^BMC4P0"
  1.  I $$NEWCP^XPDUTL("POS5-"_%,%)
  1.  ;
  1. SNDM ; --- Send mail message of install.
  1.  S %="MAIL^BMC4P0"
  1.  I $$NEWCP^XPDUTL("POS6-"_%,%)
  1.  Q
  1.  ;
  1. MAIL ;
  1.  D BMES^XPDUTL("BEGIN Delivering MailMan message to select users.")
  1.  NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
  1.  K ^TMP("BMC4P0",$J)
  1.  D RSLT(" --- BMC v 4.0, has been installed into this uci ---")
  1.  F %=1:1 D RSLT($P($T(GREET+%),";",3)) Q:$P($T(GREET+%+1),";",3)="###"
  1.  S %=0
  1.  F  S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'%   D RSLT(^(%,0))
  1.  S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""BMC4P0"",$J,",XMY(1)="",XMY(DUZ)=""
  1.  F %="BMCZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
  1.  D ^XMD
  1.  KILL ^TMP("BMC4P0",$J)
  1.  D MES^XPDUTL("END Delivering MailMan message to select users.")
  1.  Q
  1.  ;
  1. RSLT(%) S ^(0)=$G(^TMP("BMC4P0",$J,0))+1,^(^(0))=%
  1.  Q
  1.  ;
  1. SINGLE(K) ; Get holders of a single key K.
  1.  NEW Y
  1.  S Y=0
  1.  Q:'$D(^XUSEC(K))
  1.  F  S Y=$O(^XUSEC(K,Y)) Q:'Y  S XMY(Y)=""
  1.  Q
  1.  ;
  1. GREET ;;To add to mail message.
  1.  ;;  
  1.  ;;Greetings.
  1.  ;;  
  1.  ;;Standard data dictionaries on your RPMS system have been updated.
  1.  ;;  
  1.  ;;You are receiving this message because of the particular RPMS
  1.  ;;security keys that you hold.  This is for your information, only.
  1.  ;;You need do nothing in response to this message.
  1.  ;;  
  1.  ;;Questions about this version, which is a product of the RPMS DBA
  1.  ;;,
  1.  ;;can be directed to the Help Desk,
  1.  ;;.
  1.  ;;Please refer to "bmc 4.0.
  1.  ;;  
  1.  ;;###;NOTE: This line indicates the end of text in this message.
  1.  ;
  1.  ; -----------------------------------------------------
  1.  ; The global location for dictionary audit is:
  1.  ;           ^DD(FILE,0,"DDA")
  1.  ; If the valuey is "Y", dd audit is on.  Any other value, or the
  1.  ; absence of the node, means dd audit is off.
  1.  ; -----------------------------------------------------
  1. AUDR ; Restore the file data audit values to their original values.
  1.  D BMES^XPDUTL("Restoring DD AUDIT settings for RCIS files.")
  1.  NEW BMC
  1.  S BMC=0
  1.  F  S BMC=$O(^XTMP("BMC4P0",BMC)) Q:'BMC  D
  1.  . S ^DD(BMC,0,"DDA")=^XTMP("BMC4P0",BMC,"DDA")
  1.  . D MES^XPDUTL(" File "_$$RJ^XLFSTR(BMC,12)_" - "_$$LJ^XLFSTR($$GET1^DID(BMC,"","","NAME"),30)_"- DD AUDIT Set to '"_^DD(BMC,0,"DDA")_"'")
  1.  .Q
  1.  KILL ^XTMP("BMC4P0")
  1.  D MES^XPDUTL("DD AUDIT settings restored.")
  1.  Q
  1.  ; -----------------------------------------------------
  1.  ;
  1. INSTALL(BMC) ;EP; Determine if VERSION OF BMC was installed, where BMC is
  1.  ; the name of the INSTALL.  E.g "BMC 4.00".
  1.  NEW DIC,X,Y
  1.  ;  lookup package.
  1.  S X=$P(BMC," ",1)
  1.  S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
  1.  D IX^DIC
  1.  I Y<1 Q 0
  1.  ;  lookup version.
  1.  S DIC=DIC_+Y_",22,",X=$P(BMC," ",2)
  1.  D ^DIC
  1.  I Y<1 Q 0
  1.  Q $S(Y<1:0,1:1)
  1.  ; -----------------------------------------------------
  1. INSTALLD(BMC) ; Determine if patch BMC was installed, where BMC is
  1.  ; the name of the INSTALL.  E.g "AVA*93.2*12".
  1.  NEW DIC,X,Y
  1.  ;  lookup package.
  1.  S X=$P(BMC,"*",1)
  1.  S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
  1.  D IX^DIC
  1.  I Y<1 Q 0
  1.  ;  lookup version.
  1.  S DIC=DIC_+Y_",22,",X=$P(BMC,"*",2)
  1.  D ^DIC
  1.  I Y<1 Q 0
  1.  ;  lookup patch.
  1.  S DIC=DIC_+Y_",""PAH"",",X=$P(BMC,"*",3)
  1.  D ^DIC
  1.  Q $S(Y<1:0,1:1)
  1.  ; -----------------------------------------------------
  1. V4SEC ;Move Sec Ref to RCIS Ref file
  1.  Q:$$INSTALL^BMC4P0("BMC 4.0T")  ;Q IF V4.0 INSTALLED
  1.  Q:$$INSTALL^BMC4P0("BMC 4.0")  ;Q IF V4.0 INSTALLED
  1.  D SETMGR Q:XPDQUIT=2
  1.  D BMES^XPDUTL("Moving Secondary Referrals to RCIS Referral file.")
  1.  ;BMCNEW=NEW SR ENTRY IN RCIS REF FILE
  1.  ;BMCIEN=PRIM REF LINK TO SEC REF ;BMCSRIEN=SEC REF IN OLD FILE
  1.  S BMCINST="SETSEC" D SETVARS
  1.  Q:$P(^XTMP("BMC4IN",BMCJOB,BMCINST),U)="C"
  1.  Q:'$D(^BMCPROV("AD"))
  1.  S BMCIEN=BMC F  S BMCIEN=$O(^BMCPROV("AD",BMCIEN)) Q:BMCIEN'?1N.N  D
  1.  .S BMCSRIEN="" I BMCIEN=BMC S BMCSRIEN=$P(^XTMP("BMC4IN",BMCJOB,BMCINST),U,4)
  1.  .F  S BMCSRIEN=$O(^BMCPROV("AD",BMCIEN,BMCSRIEN)) Q:BMCSRIEN'?1N.N  D
  1.  ..S BMCCT=BMCCT+1 I BMCCT#100=1 W "."
  1.  ..D V4SADD I $D(^BMCPROV(BMCSRIEN,1)) D V4COM
  1.  ..Q:$D(^XTMP("BMC4IN",BMCJOB,"SEC",BMCSRIEN))
  1.  ..S $P(^XTMP("BMC4IN",BMCJOB,BMCINST),U,3,4)=BMCCT_U_BMCSRIEN
  1.  .S $P(^XTMP("BMC4IN",BMCJOB,BMCINST),U,2)=BMCIEN
  1.  D BMES^XPDUTL("COMPLETED Moving Secondary Referrals.")
  1.  Q
  1. V4SADD ;ADD SEC REF TO RCIS REF FILE
  1.  S X=$P(^BMCPROV(BMCSRIEN,0),U)
  1.  S DLAYGO=90001,DIADD=1,DIC(0)="L",DIC="^BMCREF(" D ^DIC
  1.  I Y=-1 S ^XTMP("BMC4IN",BMCJOB,"SEC",BMCSRIEN)="" Q
  1.  S DIE=DIC,(DA,BMCNEW)=+Y
  1.  F X=1:1:8 S BMC(X)=$P(^BMCPROV(BMCSRIEN,0),U,X)
  1.  F X=1:1:8 S BMC(2_X)=$P(^BMCPROV(BMCSRIEN,2),U,X)
  1.  S BMC(7)=$TR(BMC(7),";",",")
  1.  S BMC(9)=$P(^BMCREF(BMCIEN,0),U,2)
  1.  S BMC(10)=$P(^BMCREF(BMCIEN,0),U,5)
  1.  S DR=".03////"_BMC(2)_";.04////"_BMC(22)_";.06////"_BMC(24)_";.07////"_BMC(5)
  1.  S DR=DR_";.08////"_BMC(8)_";.09////"_BMC(25)_";.11////"_BMC(26)_";.12////"_BMC(27)_";.13////"_BMC(28)
  1.  D ^DIE K DR
  1.  S DR=".14////O;.15////A;.25////"_BMC(4)_";.26////"_BMC(1)
  1.  S DR=DR_";1105////"_BMC(6)_";1111////"_BMC(23)_";1201////"_BMC(7)
  1.  S DR=DR_";.02////"_BMC(9)_";.05////"_BMC(10)_";101////"_BMC(21)_";102////"_BMCIEN
  1.  D ^DIE
  1.  K DIC,DIE,DA,DR,D
  1.  Q
  1. V4COM ;UPDATE COMMENTS FILE WITH SEC REF COMMENTS
  1.  ;Mv Medical HX to the RCIS Comments file, user stamped w/CHS Supervisor
  1.  ;and dt stamped w/install dt ;lv com in Sec Ref and Del later
  1.  ;
  1.  S BMCFAC=$P(^BMCREF(BMCNEW,0),U,5)
  1.  Q:BMCFAC=""
  1.  Q:'$G(BMCMGR(BMCFAC))
  1.  S BMCPAT=$P(^BMCREF(BMCNEW,0),U,3)
  1.  S BMCMGRX=BMCMGR(BMCFAC)
  1.  I $D(^BMCPROV(BMCSRIEN,1)) S BMC2=0 D
  1.  .S BMCTYP="M"
  1.  .S BMCCDT=$P(^BMCPROV(BMCSRIEN,1,0),U,5)
  1.  .I BMCCDT="" S BMCCDT=DT
  1.  .D ADD
  1.  .F  S BMC2=$O(^BMCPROV(BMCSRIEN,1,BMC2)) Q:BMC2'?1N.N  D
  1.  ..S X=^BMCPROV(BMCSRIEN,1,BMC2,0)
  1.  ..S ^BMCCOM(BMCCIEN,1,BMC2,0)=X
  1.  Q
  1. ADD ;ADD ENTRY
  1.  S X=BMCCDT,DLAYGO=90001.03,DIADD=1,DIC(0)="L",DIC="^BMCCOM(" D ^DIC
  1.  S DIE=DIC
  1.  S DR=".02////"_BMCPAT_";.03////"_BMCNEW_";.04////"_BMCMGRX_";.05////"_BMCTYP
  1.  D ^DIE
  1.  S BMCCIEN=DA S ^BMCCOM(BMCCIEN,1,0)=^BMCPROV(BMCSRIEN,1,0)
  1.  S $P(^BMCCOM(BMCCIEN,1,0),U,2)="90001.031"
  1.  K DIC,DIE,DA,DR,D
  1.  Q
  1. V4CLS ;CHANGE "C2" TO "X" CLOSE STATUS   
  1.  Q:$$INSTALL^BMC4P0("BMC 4.0T")  ;Q IF V4.0 INSTALLED
  1.  Q:$$INSTALL^BMC4P0("BMC 4.0")  ;Q IF V4.0 INSTALLED
  1.  D BMES^XPDUTL("Change the close status of referral from 'C2' to 'X'.")
  1.  S BMCINST="SETCLS",BMCCT1=0 D SETVARS
  1.  Q:$P(^XTMP("BMC4IN",BMCJOB,BMCINST),U)="C"
  1.  F  S BMC=$O(^BMCREF(BMC)) Q:BMC'?1N.N  D
  1.  .S BMCCT1=BMCCT1+1 I BMCCT1#1000=1 W "."
  1.  .S $P(^XTMP("BMC4IN",BMCJOB,BMCINST),U,2)=BMC
  1.  .Q:$P(^BMCREF(BMC,0),U,15)'="C2"
  1.  .S DA=BMC,DIE="^BMCREF(",DR=".15////X" D ^DIE
  1.  .S BMCCT=BMCCT+1,$P(^XTMP("BMC4IN",BMCJOB,BMCINST),U,3)=BMCCT
  1.  S $P(^XTMP("BMC4IN",BMCJOB,BMCINST),U)="C"  ;COMPLETED
  1.  D BMES^XPDUTL("Completed changing the close status of referral.")
  1.  Q
  1.  ; -----------------------------------------------------
  1. V4OPT ;REMOVE CHS DENIAL REPORT OPT
  1.  Q:$$INSTALL^BMC4P0("BMC 4.0T")  ;Q IF V4.0 INSTALLED
  1.  Q:$$INSTALL^BMC4P0("BMC 4.0")  ;Q IF V4.0 INSTALLED
  1.  D BMES^XPDUTL("BEGIN Removing CHS Denial report option.")
  1.  ;DOES NOT NEED TO BE REMOVED FROM PARENT OPTION, BECAUSE IT IS NOT SENT
  1.  ;WITH THE BUILD
  1.  S DA=$O(^DIC(19,"B","BMC RPT-CHS DENIED/ACTIVE",0)) I DA S DIK="^DIC(19," D ^DIK
  1.  D MES^XPDUTL("END Removing CHS Denial Report Referral option.")
  1.  Q
  1.  ; -----------------------------------------------------
  1. SETVARS ;EP;SET VARS AND TST IF INSTALL ALREADY STARTED, BUT DID NOT COMPLETE
  1.  I $D(^XTMP("BMC4IN")) S BMCJOB=0,BMCJOB=$O(^XTMP("BMC4IN",BMCJOB))
  1.  I $D(BMCJOB),$D(^XTMP("BMC4IN",BMCJOB,BMCINST)) D
  1.  .S BMC=$P(^XTMP("BMC4IN",BMCJOB,BMCINST),U,2),BMCCT=$P(^(BMCINST),U,3)
  1.  E  S BMCJOB=$J,^XTMP("BMC4IN",BMCJOB,BMCINST)="N^0",(BMC,BMCCT)=0
  1.  Q
  1.  ; -----------------------------------------------------
  1. SETMGR ;SET DEFAULT MANAGER
  1.  S X=0,BMCER=0,XPDQUIT=""
  1.  F  S X=$O(^BMCPARM("B",X)) Q:X'?1N.N  D
  1.  .S BMCMGR(X)=$P(^BMCPARM(X,0),U,13)
  1.  .I BMCMGR(X)'>0 S BMCER=1
  1.  I BMCER=1 W !,"CHS SUPERVISOR is not entered in RCIS SITE PARAMETER FILE, INSTALL ABORTED" S XPDQUIT=2 Q
  1.  Q
  1.  ; -----------------------------------------------------