BMC4P9 ;IHS/OIT/FCJ - BMC 4.0 PATCH 9 ; 16 Feb 2011 2:54 PM
;;4.0;REFERRED CARE INFO SYSTEM;**9**;JAN 09, 2006;Build 45
;ORIGINAL ROUTINE FR BMC4P8
;
I '$G(IOM) D HOME^%ZIS
;
I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY(2) Q
;
I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY(2) Q
;
I '(DUZ(0)["@") W:'$D(ZTQUEUED) !,"DUZ(0) DOES NOT CONTAIN AN '@'." D SORRY(2) Q
;
S X=$$GET1^DIQ(200,DUZ,.01)
W !!,$$CJ^XLFSTR("Hello, "_$P(X,",",2)_" "_$P(X,","),IOM)
W !!,$$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_".",IOM),!
;
NEW IORVON,IORVOFF
S X="IORVON;IORVOFF"
D ENDR^%ZISS
;
I $$VCHK("BMC","4.0",2,"'=")
I $$VCHK("DI","22.0",2,"<")
I $$VCHK("XU","8.0",2,"<")
I $$VCHK^BMC4P9("AICD","4.0",2,"<")
I '$$INSTALLD("AG*7.1*11") S BMCQUIT=2 D SORRY(BMCQUIT)
I '$$INSTALLD("AUPN*99.1*16") S BMCQUIT=2 D SORRY(BMCQUIT)
I '$$INSTALLD("ATX*5.1*5") S BMCQUIT=2 D SORRY(BMCQUIT)
I '$$INSTALLD("AUT*98.1*26") S BMCQUIT=2 D SORRY(BMCQUIT)
I '$$INSTALLD("LEX*2.0*1003") S BMCQUIT=2 D SORRY(BMCQUIT)
I '$$INSTALLD("OR*3.0*190") S BMCQUIT=2 D SORRY(BMCQUIT)
I $$VCHK("BSTS","1.0",2,"'=")
W !!
S DIR(0)="Y0",DIR("A")="Is the Facility using PCC" D ^DIR
I +Y>0,'$$INSTALLD("BJPC*2.0*10") S BMCQUIT=2 D SORRY(BMCQUIT)
W !
S DIR(0)="Y0",DIR("A")="Is the Facility using EHR" D ^DIR
I +Y>0,'$$INSTALLD("BGO*1.1*13") S BMCQUIT=2 D SORRY(BMCQUIT) W !
;
NEW DA,DIC
S X="BMC",DIC="^DIC(9.4,",DIC(0)="",D="C"
D IX^DIC
I Y<0,$D(^DIC(9.4,"C","BMC")) D
. W !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""BMC"" prefix.",IOM)
. W !,$$CJ^XLFSTR(IORVON_"One entry needs to be deleted."_IORVOFF,IOM)
. D SORRY(2)
;
I $G(XPDQUIT) W !,$$CJ^XLFSTR(IORVON_"You will need to update package(s) before proceeding."_IORVOFF,IOM),!!,*7,*7,*7 Q
W !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
D HELP^XBHELP("INTROE","BMC4P9")
I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2) Q
I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0 D HELP^XBHELP("INTROI","BMC4P9") I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2)
Q
;
SORRY(X) ;
KILL DIFQ
S XPDQUIT=X
W *7,!,$$CJ^XLFSTR("Sorry....Need to update package!",IOM)
Q
;
VCHK(BMCPRE,BMCVER,BMCQUIT,BMCCOMP) ; Check versions needed.
;
NEW BMCV
S BMCV=$$VERSION^XPDUTL(BMCPRE)
I BMCV="" D Q 0
.W !,$$CJ^XLFSTR("Need "_$S(BMCCOMP="<":"at least ",1:"")_BMCPRE_" v "_BMCVER_"....."_BMCPRE_" v "_BMCV_" Not Present",IOM)
.D SORRY(BMCQUIT)
W !,$$CJ^XLFSTR("Need "_$S(BMCCOMP="<":"at least ",1:"")_BMCPRE_" v "_BMCVER_"....."_BMCPRE_" v "_BMCV_" Present",IOM)
I @(BMCV_BMCCOMP_BMCVER) D SORRY(BMCQUIT) Q 0
Q 1
;
INSTALLD(BMC) ; Determine if patch BMC was installed, where BMC is
; the name of the INSTALL. E.g "AVA*93.2*12".
;
NEW DIC,X,Y,P
; lookup package.
S X=$P(BMC,"*",1)
S DIC="^DIC(9.4,",DIC(0)="FM",D="C"
D IX^DIC
I Y<1 Q 0
; lookup version.
S DIC=DIC_+Y_",22,",X=$P(BMC,"*",2)
D ^DIC
I Y<1 Q 0
; lookup patch.
S DIC=DIC_+Y_",""PAH"",",X=$P(BMC,"*",3)
D ^DIC
I Y<1 S P=DIC_"""B"","_X_")" I $O(@P)'="" S Y=1
I Y>0 W !,$$CJ^XLFSTR("Need at least "_BMC_"....."_BMC_" Present",IOM)
I Y<0 W !,$$CJ^XLFSTR("Need at least "_BMC_".....",IOM)
Q $S(Y<1:0,1:1)
;
; -----------------------------------------------------
PRE ;EP - From KIDS.
I $$NEWCP^XPDUTL("PRE1","AUDS^BMC4P9")
; The following line prevents the "Disable Options..." and "Move
; Routines..." questions from being asked during the install.
I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
Q
;
POST ;EP - From KIDS.
; --- Restore dd audit settings.
S %="AUDR^BMC4P9"
I $$NEWCP^XPDUTL("POS1-"_%,%)
;
; --- Set new Index "BA" and "BB"
S %="INDX^BMC4P9"
I $$NEWCP^XPDUTL("POS2-"_%,%)
;
; --- Add Provider/Vendor Option
S %="P5^BMC4P9"
I $$NEWCP^XPDUTL("POS3-"_%,%)
;
; --- Add MED HX Option and fx CHS 2010 PO #'s
S %="P6^BMC4P9"
I $$NEWCP^XPDUTL("POS4-"_%,%)
;
; --- Add Report Option for printing C32s for Active referrals
S %="P7^BMC4P9"
I $$NEWCP^XPDUTL("POS5-"_%,%)
;
; --- Add Report Option for TOC and Edit option for TOC
S %="P8^BMC4P9"
I $$NEWCP^XPDUTL("POS6-"_%,%)
;
; ---Re-Add Report Options, removed because a parent opt sent
S %="P9^BMC4P9"
I $$NEWCP^XPDUTL("POS7-"_%,%)
;
; --- Send mail message of install.
S %="MAIL^BMC4P9"
I $$NEWCP^XPDUTL("POS8-"_%,%)
;
Q
;
MAIL ;
D BMES^XPDUTL("BEGIN Delivering MailMan message to select users.")
NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
KILL ^TMP("BMC4P9",$J)
D RSLT(" --- BMC v 4.0 Patch 8, has been installed into this namespace ---")
F %=1:1 D RSLT($P($T(GREET+%),";",3)) Q:$P($T(GREET+%+1),";",3)="###"
S %=0
F S %=$O(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%)) Q:'% D RSLT(^(%,0))
S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""BMC4P9"",$J,",XMY(1)="",XMY(DUZ)=""
F %="BMCZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
D ^XMD
KILL ^TMP("BMC4P9",$J)
D MES^XPDUTL("END Delivering MailMan message to select users.")
Q
;
RSLT(%) S ^(0)=$G(^TMP("BMC4P9",$J,0))+1,^(^(0))=%
Q
;
SINGLE(K) ; Get holders of a single key K.
NEW Y
S Y=0
Q:'$D(^XUSEC(K))
F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)=""
Q
;
INTROE ; Intro text during KIDS Environment check.
;;In this distribution:
;;
;; Multiple changes for ICD-10, see the
;; requirement's documentation for additional information
;;
;;
;;###
;
INTROI ; Intro text during KIDS Install.
;;A standard message will be produced by this update.
;;
;;If you run interactively, results will be displayed on your screen,
;;as well as in the mail message and the entry in the INSTALL file.
;;If you queue to TaskMan, please read the mail message for results of
;;this update, and remember not to Q to the HOME device.
;;###
;
GREET ;;To add to mail message.
;;
;;Greetings.
;;
;;The RCIS package on your RPMS system has been updated.
;;
;;You are receiving this message because of the particular RPMS
;;security keys that you hold. This is for your information, only.
;;You need do nothing in response to this message.
;;
;;Questions about this patch, which is a product of the RPMS developer
;;(Fonda Jackson at 971.235.5714),
;;can be directed to the DIR/RPMS Support Center, at 505-248-4371,
;;or via e-mail to "oithelp@ihs.gov".
;;Please refer to patch "bmc*4.0*9".
;;
;;###;NOTE: This line indicates the end of text in this message.
;
; -----------------------------------------------------
; The global location for dictionary audit is:
; ^DD(FILE,0,"DDA")
; If the valuey is "Y", dd audit is on. Any other value, or the
; absence of the node, means dd audit is off.
; -----------------------------------------------------
AUDS ;EP - From KIDS.
D BMES^XPDUTL("Saving current DD AUDIT settings for files in this patch")
D MES^XPDUTL("and turning DD AUDIT to 'Y'.")
S ^XTMP("BMC4P9",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^"_$P($P($T(+1),";",2)," ",3,99)
NEW BMC
S BMC=0
F S BMC=$O(^XTMP("XPDI",XPDA,"FIA",BMC)) Q:'BMC D
. I '$D(^XTMP("BMC4P9",BMC,"DDA")) S ^XTMP("BMC4P9",BMC,"DDA")=$G(^DD(BMC,0,"DDA"))
. D MES^XPDUTL(" File "_$$RJ^XLFSTR(BMC,12)_" - "_$$LJ^XLFSTR(^XTMP("XPDI",XPDA,"FIA",BMC),30)_"- DD audit was '"_$G(^XTMP("BMC4P9",BMC,"DDA"))_"'"),MES^XPDUTL($$RJ^XLFSTR("Set to 'Y'",69))
. S ^DD(BMC,0,"DDA")="Y"
.Q
D MES^XPDUTL("DD AUDIT settings saved in ^XTMP(.")
Q
; -----------------------------------------------------
AUDR ; Restore the file data audit values to their original values.
D BMES^XPDUTL("Restoring DD AUDIT settings for files in this patch.")
NEW BMC
S BMC=0
F S BMC=$O(^XTMP("BMC4P9",BMC)) Q:'BMC D
. S ^DD(BMC,0,"DDA")=^XTMP("BMC4P9",BMC,"DDA")
. D MES^XPDUTL(" File "_$$RJ^XLFSTR(BMC,12)_" - "_$$LJ^XLFSTR($$GET1^DID(BMC,"","","NAME"),30)_"- DD AUDIT Set to '"_^DD(BMC,0,"DDA")_"'")
.Q
KILL ^XTMP("BMC4P9")
D MES^XPDUTL("DD AUDIT settings restored.")
Q
; -----------------------------------------------------
INDX ;INDEX NEW INDECIES "BA", "BB" AND "CD" ;Patch 2
S BMC="BMC*4.0*2" Q:$$INSTALLD^BMC4P0(BMC)
D BMES^XPDUTL("BEGIN Indexing Expected Begining Date of Service.")
S DIK="^BMCREF("
S DIK(1)="1105^BA"
D ENALL^DIK
D BMES^XPDUTL("BEGIN Indexing Actual Appointment/begin DOS.")
S DIK(1)="1106^BB"
D ENALL^DIK
D BMES^XPDUTL("BEGIN Indexing CHS Denial Number.")
S DIK(1)="1128^CD"
D ENALL^DIK
D BMES^XPDUTL("Completed updating new indexes.")
K DA,DIC,DIK,X
Q
; -----------------------------------------------------
P5 ;Add Menu option for Vendor
S BMC="BMC*4.0*5" Q:$$INSTALLD^BMC4P0(BMC)
D BMES^XPDUTL("Begin adding new Provider/Vendor option.")
I $$ADD^XPDMENU("BMCMENU","BMCVEN","VEN") D MES^XPDUTL($J("",5)_"Provider/Vendor add/edit Menu added to RCIS Main Menu")
D MES^XPDUTL("END updating option.")
Q
; -----------------------------------------------------
P6 ;FX CHS PO'S WITH FY 00 INSTEAD OF FY 10
S BMC="BMC*4.0*6" Q:$$INSTALLD^BMC4P0(BMC)
D MES^XPDUTL("Updating CHS 2010 PO Numbers.")
S BMC=3090900 F S BMC=$O(^BMCREF("B",BMC)) Q:BMC'?1N.N D
.S BMC1="" F S BMC1=$O(^BMCREF("B",BMC,BMC1)) Q:BMC1'?1N.N D
..I $D(^BMCREF(BMC1,41)) S BMC2=0 F S BMC2=$O(^BMCREF(BMC1,41,BMC2)) Q:BMC2'?1N.N D
...S BMCPO=$P(^BMCREF(BMC1,41,BMC2,0),U,8)
...I $E(BMCPO,1,2)="00",$L(BMCPO)=12 D
....S $P(^BMCREF(BMC1,41,BMC2,0),U,8)="10"_$E(BMCPO,3,12)
....S $P(^BMCREF(BMC1,41,BMC2,11),U)=10
D BMES^XPDUTL("Begin adding option for Adding Med Hx comments.")
I $$ADD^XPDMENU("BMC MENU EDIT REFERRAL","BMC MED HX COMMENTS","MED") D MES^XPDUTL($J("",5)_"Enter Medical Hx Comments Menu added to RCIS Edit Menu")
D MES^XPDUTL("END updating option.")
Q
; ------------------------------------------------------
P7 ;Adding new Report menu option for the printed C32
S BMC="BMC*4.0*7" Q:$$INSTALLD^BMC4P0(BMC)
D BMES^XPDUTL("Begin adding option for Active referrals without a printed C32.")
I $$ADD^XPDMENU("BMC MENU-RPTS ADMINISTRATIVE","BMC RPT-ACTIVE REFERRALS-C32","ARC") D MES^XPDUTL($J("",5)_"Report for Active ref w/o a C32 Menu added to Adm Report option")
D MES^XPDUTL("END updating option.")
Q
; ------------------------------------------------------
P8 ;Adding new Report menu option for TOC and Edit option for TOC
S BMC="BMC*4.0*8"
G:$$INSTALLD^BMC4P0(BMC) PCCLNK
D BMES^XPDUTL("Begin adding option for TOC Report for Approved referrals pending a TOC document.")
I $$ADD^XPDMENU("BMC MENU-RPTS ADMINISTRATIVE","BMC RPT-APPRV REF TOC PENDING","TOCR") D MES^XPDUTL($J("",5)_"Report for Approved ref w/o a TOC option added to Adm Report option")
D BMES^XPDUTL("Begin adding Edit option for TOC Information.")
I $$ADD^XPDMENU("BMC MENU EDIT REFERRAL","BMC MOD TOC","TOC") D MES^XPDUTL($J("",5)_"Edit Option for TOC information for Approved Referrals.")
D MES^XPDUTL("END updating option.")
;
PCCLNK ;Add RCIS to PCC Visit Merge Utility
;NEW INDEX NEED TO REINDEX FOR BETA SITES
S DIK="^BMCREF(",DIK(1)="1309^VSTR" D ENALL^DIK K DIK
I $D(^APCDLINK("B","REFERRED CARE INFORMATION SYST")) D ;already exists
.S DA=0,DA=$O(^APCDLINK("B","REFERRED CARE INFORMATION SYST",DA))
.S DIE="^APCDLINK(",DR=".01///REFERRED CARE INFORMATION SYS;1///I $L($T(MRG^BMCPCCV))"
.D ^DIE K DIE,DA,DR
Q:$D(^APCDLINK("B","REFERRED CARE INFORMATION SYS")) ;already exists
D BMES^XPDUTL("Adding RCIS to PCC Visit Merge Utility . . .")
NEW DD,DO,DIC,DLAYGO,X,Y
S DIC="^APCDLINK(",DIC(0)="LE",DLAYGO=9001002
S DIC("DR")=".02///BMC;1///I $L($T(MRG^BMCPCCV)) D MRG^BMCPCCV;3///I $L($T(DEL^BMCPCCV)) D DEL^BMCPCCV"
S X="REFERRED CARE INFORMATION SYS" D FILE^DICN
Q
; ------------------------------------------------------
P9 ;Add Report menu options
D MES^XPDUTL("Begin updating Special Print Menu option.")
I $$ADD^XPDMENU("BMC MENU SPECIAL","BMC DISPLAY REFERRAL RECORD","DSP")
I $$ADD^XPDMENU("BMC MENU SPECIAL","BMC PRINT REFERRAL FORMS","PRF")
I $$ADD^XPDMENU("BMC MENU SPECIAL","BMC PRINT ROUTING SLIP","PRS")
I $$ADD^XPDMENU("BMC MENU SPECIAL","BMC MENU-PRINT REPORTS","RPT")
D MES^XPDUTL("END updating Special Print Menu option.")
;
BMC4P9 ;IHS/OIT/FCJ - BMC 4.0 PATCH 9 ; 16 Feb 2011 2:54 PM
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**9**;JAN 09, 2006;Build 45
+2 ;ORIGINAL ROUTINE FR BMC4P8
+3 ;
+4 IF '$GET(IOM)
DO HOME^%ZIS
+5 ;
+6 IF '$GET(DUZ)
WRITE !,"DUZ UNDEFINED OR 0."
DO SORRY(2)
QUIT
+7 ;
+8 IF '$LENGTH($GET(DUZ(0)))
WRITE !,"DUZ(0) UNDEFINED OR NULL."
DO SORRY(2)
QUIT
+9 ;
+10 IF '(DUZ(0)["@")
IF '$DATA(ZTQUEUED)
WRITE !,"DUZ(0) DOES NOT CONTAIN AN '@'."
DO SORRY(2)
QUIT
+11 ;
+12 SET X=$$GET1^DIQ(200,DUZ,.01)
+13 WRITE !!,$$CJ^XLFSTR("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","),IOM)
+14 WRITE !!,$$CJ^XLFSTR("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_$PIECE($TEXT(+2),";",3)_".",IOM),!
+15 ;
+16 NEW IORVON,IORVOFF
+17 SET X="IORVON;IORVOFF"
+18 DO ENDR^%ZISS
+19 ;
+20 IF $$VCHK("BMC","4.0",2,"'=")
+21 IF $$VCHK("DI","22.0",2,"<")
+22 IF $$VCHK("XU","8.0",2,"<")
+23 IF $$VCHK^BMC4P9("AICD","4.0",2,"<")
+24 IF '$$INSTALLD("AG*7.1*11")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
+25 IF '$$INSTALLD("AUPN*99.1*16")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
+26 IF '$$INSTALLD("ATX*5.1*5")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
+27 IF '$$INSTALLD("AUT*98.1*26")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
+28 IF '$$INSTALLD("LEX*2.0*1003")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
+29 IF '$$INSTALLD("OR*3.0*190")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
+30 IF $$VCHK("BSTS","1.0",2,"'=")
+31 WRITE !!
+32 SET DIR(0)="Y0"
SET DIR("A")="Is the Facility using PCC"
DO ^DIR
+33 IF +Y>0
IF '$$INSTALLD("BJPC*2.0*10")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
+34 WRITE !
+35 SET DIR(0)="Y0"
SET DIR("A")="Is the Facility using EHR"
DO ^DIR
+36 IF +Y>0
IF '$$INSTALLD("BGO*1.1*13")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
WRITE !
+37 ;
+38 NEW DA,DIC
+39 SET X="BMC"
SET DIC="^DIC(9.4,"
SET DIC(0)=""
SET D="C"
+40 DO IX^DIC
+41 IF Y<0
IF $DATA(^DIC(9.4,"C","BMC"))
Begin DoDot:1
+42 WRITE !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""BMC"" prefix.",IOM)
+43 WRITE !,$$CJ^XLFSTR(IORVON_"One entry needs to be deleted."_IORVOFF,IOM)
+44 DO SORRY(2)
End DoDot:1
+45 ;
+46 IF $GET(XPDQUIT)
WRITE !,$$CJ^XLFSTR(IORVON_"You will need to update package(s) before proceeding."_IORVOFF,IOM),!!,*7,*7,*7
QUIT
+47 WRITE !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
+48 DO HELP^XBHELP("INTROE","BMC4P9")
+49 IF '$$DIR^XBDIR("E","","","","","",1)
DO SORRY(2)
QUIT
+50 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
DO HELP^XBHELP("INTROI","BMC4P9")
IF '$$DIR^XBDIR("E","","","","","",1)
DO SORRY(2)
+51 QUIT
+52 ;
SORRY(X) ;
+1 KILL DIFQ
+2 SET XPDQUIT=X
+3 WRITE *7,!,$$CJ^XLFSTR("Sorry....Need to update package!",IOM)
+4 QUIT
+5 ;
VCHK(BMCPRE,BMCVER,BMCQUIT,BMCCOMP) ; Check versions needed.
+1 ;
+2 NEW BMCV
+3 SET BMCV=$$VERSION^XPDUTL(BMCPRE)
+4 IF BMCV=""
Begin DoDot:1
+5 WRITE !,$$CJ^XLFSTR("Need "_$SELECT(BMCCOMP="<":"at least ",1:"")_BMCPRE_" v "_BMCVER_"....."_BMCPRE_" v "_BMCV_" Not Present",IOM)
+6 DO SORRY(BMCQUIT)
End DoDot:1
QUIT 0
+7 WRITE !,$$CJ^XLFSTR("Need "_$SELECT(BMCCOMP="<":"at least ",1:"")_BMCPRE_" v "_BMCVER_"....."_BMCPRE_" v "_BMCV_" Present",IOM)
+8 IF @(BMCV_BMCCOMP_BMCVER)
DO SORRY(BMCQUIT)
QUIT 0
+9 QUIT 1
+10 ;
INSTALLD(BMC) ; Determine if patch BMC was installed, where BMC is
+1 ; the name of the INSTALL. E.g "AVA*93.2*12".
+2 ;
+3 NEW DIC,X,Y,P
+4 ; lookup package.
+5 SET X=$PIECE(BMC,"*",1)
+6 SET DIC="^DIC(9.4,"
SET DIC(0)="FM"
SET D="C"
+7 DO IX^DIC
+8 IF Y<1
QUIT 0
+9 ; lookup version.
+10 SET DIC=DIC_+Y_",22,"
SET X=$PIECE(BMC,"*",2)
+11 DO ^DIC
+12 IF Y<1
QUIT 0
+13 ; lookup patch.
+14 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(BMC,"*",3)
+15 DO ^DIC
+16 IF Y<1
SET P=DIC_"""B"","_X_")"
IF $ORDER(@P)'=""
SET Y=1
+17 IF Y>0
WRITE !,$$CJ^XLFSTR("Need at least "_BMC_"....."_BMC_" Present",IOM)
+18 IF Y<0
WRITE !,$$CJ^XLFSTR("Need at least "_BMC_".....",IOM)
+19 QUIT $SELECT(Y<1:0,1:1)
+20 ;
+21 ; -----------------------------------------------------
PRE ;EP - From KIDS.
+1 IF $$NEWCP^XPDUTL("PRE1","AUDS^BMC4P9")
+2 ; The following line prevents the "Disable Options..." and "Move
+3 ; Routines..." questions from being asked during the install.
+4 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+5 QUIT
+6 ;
POST ;EP - From KIDS.
+1 ; --- Restore dd audit settings.
+2 SET %="AUDR^BMC4P9"
+3 IF $$NEWCP^XPDUTL("POS1-"_%,%)
+4 ;
+5 ; --- Set new Index "BA" and "BB"
+6 SET %="INDX^BMC4P9"
+7 IF $$NEWCP^XPDUTL("POS2-"_%,%)
+8 ;
+9 ; --- Add Provider/Vendor Option
+10 SET %="P5^BMC4P9"
+11 IF $$NEWCP^XPDUTL("POS3-"_%,%)
+12 ;
+13 ; --- Add MED HX Option and fx CHS 2010 PO #'s
+14 SET %="P6^BMC4P9"
+15 IF $$NEWCP^XPDUTL("POS4-"_%,%)
+16 ;
+17 ; --- Add Report Option for printing C32s for Active referrals
+18 SET %="P7^BMC4P9"
+19 IF $$NEWCP^XPDUTL("POS5-"_%,%)
+20 ;
+21 ; --- Add Report Option for TOC and Edit option for TOC
+22 SET %="P8^BMC4P9"
+23 IF $$NEWCP^XPDUTL("POS6-"_%,%)
+24 ;
+25 ; ---Re-Add Report Options, removed because a parent opt sent
+26 SET %="P9^BMC4P9"
+27 IF $$NEWCP^XPDUTL("POS7-"_%,%)
+28 ;
+29 ; --- Send mail message of install.
+30 SET %="MAIL^BMC4P9"
+31 IF $$NEWCP^XPDUTL("POS8-"_%,%)
+32 ;
+33 QUIT
+34 ;
MAIL ;
+1 DO BMES^XPDUTL("BEGIN Delivering MailMan message to select users.")
+2 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+3 KILL ^TMP("BMC4P9",$JOB)
+4 DO RSLT(" --- BMC v 4.0 Patch 8, has been installed into this namespace ---")
+5 FOR %=1:1
DO RSLT($PIECE($TEXT(GREET+%),";",3))
IF $PIECE($TEXT(GREET+%+1),";",3)="###"
QUIT
+6 SET %=0
+7 FOR
SET %=$ORDER(^XTMP("XPDI",XPDA,"BLD",XPDBLD,1,%))
IF '%
QUIT
DO RSLT(^(%,0))
+8 SET XMSUB=$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
SET XMTEXT="^TMP(""BMC4P9"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+9 FOR %="BMCZMENU","XUMGR","XUPROG","XUPROGMODE"
DO SINGLE(%)
+10 DO ^XMD
+11 KILL ^TMP("BMC4P9",$JOB)
+12 DO MES^XPDUTL("END Delivering MailMan message to select users.")
+13 QUIT
+14 ;
RSLT(%) SET ^(0)=$GET(^TMP("BMC4P9",$JOB,0))+1
SET ^(^(0))=%
+1 QUIT
+2 ;
SINGLE(K) ; Get holders of a single key K.
+1 NEW Y
+2 SET Y=0
+3 IF '$DATA(^XUSEC(K))
QUIT
+4 FOR
SET Y=$ORDER(^XUSEC(K,Y))
IF 'Y
QUIT
SET XMY(Y)=""
+5 QUIT
+6 ;
INTROE ; Intro text during KIDS Environment check.
+1 ;;In this distribution:
+2 ;;
+3 ;; Multiple changes for ICD-10, see the
+4 ;; requirement's documentation for additional information
+5 ;;
+6 ;;
+7 ;;###
+8 ;
INTROI ; Intro text during KIDS Install.
+1 ;;A standard message will be produced by this update.
+2 ;;
+3 ;;If you run interactively, results will be displayed on your screen,
+4 ;;as well as in the mail message and the entry in the INSTALL file.
+5 ;;If you queue to TaskMan, please read the mail message for results of
+6 ;;this update, and remember not to Q to the HOME device.
+7 ;;###
+8 ;
GREET ;;To add to mail message.
+1 ;;
+2 ;;Greetings.
+3 ;;
+4 ;;The RCIS package on your RPMS system has been updated.
+5 ;;
+6 ;;You are receiving this message because of the particular RPMS
+7 ;;security keys that you hold. This is for your information, only.
+8 ;;You need do nothing in response to this message.
+9 ;;
+10 ;;Questions about this patch, which is a product of the RPMS developer
+11 ;;(Fonda Jackson at 971.235.5714),
+12 ;;can be directed to the DIR/RPMS Support Center, at 505-248-4371,
+13 ;;or via e-mail to "oithelp@ihs.gov".
+14 ;;Please refer to patch "bmc*4.0*9".
+15 ;;
+16 ;;###;NOTE: This line indicates the end of text in this message.
+17 ;
+18 ; -----------------------------------------------------
+19 ; The global location for dictionary audit is:
+20 ; ^DD(FILE,0,"DDA")
+21 ; If the valuey is "Y", dd audit is on. Any other value, or the
+22 ; absence of the node, means dd audit is off.
+23 ; -----------------------------------------------------
AUDS ;EP - From KIDS.
+1 DO BMES^XPDUTL("Saving current DD AUDIT settings for files in this patch")
+2 DO MES^XPDUTL("and turning DD AUDIT to 'Y'.")
+3 SET ^XTMP("BMC4P9",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^"_$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
+4 NEW BMC
+5 SET BMC=0
+6 FOR
SET BMC=$ORDER(^XTMP("XPDI",XPDA,"FIA",BMC))
IF 'BMC
QUIT
Begin DoDot:1
+7 IF '$DATA(^XTMP("BMC4P9",BMC,"DDA"))
SET ^XTMP("BMC4P9",BMC,"DDA")=$GET(^DD(BMC,0,"DDA"))
+8 DO MES^XPDUTL(" File "_$$RJ^XLFSTR(BMC,12)_" - "_$$LJ^XLFSTR(^XTMP("XPDI",XPDA,"FIA",BMC),30)_"- DD audit was '"_$GET(^XTMP("BMC4P9",BMC,"DDA"))_"'")
DO MES^XPDUTL($$RJ^XLFSTR("Set to 'Y'",69))
+9 SET ^DD(BMC,0,"DDA")="Y"
+10 QUIT
End DoDot:1
+11 DO MES^XPDUTL("DD AUDIT settings saved in ^XTMP(.")
+12 QUIT
+13 ; -----------------------------------------------------
AUDR ; Restore the file data audit values to their original values.
+1 DO BMES^XPDUTL("Restoring DD AUDIT settings for files in this patch.")
+2 NEW BMC
+3 SET BMC=0
+4 FOR
SET BMC=$ORDER(^XTMP("BMC4P9",BMC))
IF 'BMC
QUIT
Begin DoDot:1
+5 SET ^DD(BMC,0,"DDA")=^XTMP("BMC4P9",BMC,"DDA")
+6 DO MES^XPDUTL(" File "_$$RJ^XLFSTR(BMC,12)_" - "_$$LJ^XLFSTR($$GET1^DID(BMC,"","","NAME"),30)_"- DD AUDIT Set to '"_^DD(BMC,0,"DDA")_"'")
+7 QUIT
End DoDot:1
+8 KILL ^XTMP("BMC4P9")
+9 DO MES^XPDUTL("DD AUDIT settings restored.")
+10 QUIT
+11 ; -----------------------------------------------------
INDX ;INDEX NEW INDECIES "BA", "BB" AND "CD" ;Patch 2
+1 SET BMC="BMC*4.0*2"
IF $$INSTALLD^BMC4P0(BMC)
QUIT
+2 DO BMES^XPDUTL("BEGIN Indexing Expected Begining Date of Service.")
+3 SET DIK="^BMCREF("
+4 SET DIK(1)="1105^BA"
+5 DO ENALL^DIK
+6 DO BMES^XPDUTL("BEGIN Indexing Actual Appointment/begin DOS.")
+7 SET DIK(1)="1106^BB"
+8 DO ENALL^DIK
+9 DO BMES^XPDUTL("BEGIN Indexing CHS Denial Number.")
+10 SET DIK(1)="1128^CD"
+11 DO ENALL^DIK
+12 DO BMES^XPDUTL("Completed updating new indexes.")
+13 KILL DA,DIC,DIK,X
+14 QUIT
+15 ; -----------------------------------------------------
P5 ;Add Menu option for Vendor
+1 SET BMC="BMC*4.0*5"
IF $$INSTALLD^BMC4P0(BMC)
QUIT
+2 DO BMES^XPDUTL("Begin adding new Provider/Vendor option.")
+3 IF $$ADD^XPDMENU("BMCMENU","BMCVEN","VEN")
DO MES^XPDUTL($JUSTIFY("",5)_"Provider/Vendor add/edit Menu added to RCIS Main Menu")
+4 DO MES^XPDUTL("END updating option.")
+5 QUIT
+6 ; -----------------------------------------------------
P6 ;FX CHS PO'S WITH FY 00 INSTEAD OF FY 10
+1 SET BMC="BMC*4.0*6"
IF $$INSTALLD^BMC4P0(BMC)
QUIT
+2 DO MES^XPDUTL("Updating CHS 2010 PO Numbers.")
+3 SET BMC=3090900
FOR
SET BMC=$ORDER(^BMCREF("B",BMC))
IF BMC'?1N.N
QUIT
Begin DoDot:1
+4 SET BMC1=""
FOR
SET BMC1=$ORDER(^BMCREF("B",BMC,BMC1))
IF BMC1'?1N.N
QUIT
Begin DoDot:2
+5 IF $DATA(^BMCREF(BMC1,41))
SET BMC2=0
FOR
SET BMC2=$ORDER(^BMCREF(BMC1,41,BMC2))
IF BMC2'?1N.N
QUIT
Begin DoDot:3
+6 SET BMCPO=$PIECE(^BMCREF(BMC1,41,BMC2,0),U,8)
+7 IF $EXTRACT(BMCPO,1,2)="00"
IF $LENGTH(BMCPO)=12
Begin DoDot:4
+8 SET $PIECE(^BMCREF(BMC1,41,BMC2,0),U,8)="10"_$EXTRACT(BMCPO,3,12)
+9 SET $PIECE(^BMCREF(BMC1,41,BMC2,11),U)=10
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 DO BMES^XPDUTL("Begin adding option for Adding Med Hx comments.")
+11 IF $$ADD^XPDMENU("BMC MENU EDIT REFERRAL","BMC MED HX COMMENTS","MED")
DO MES^XPDUTL($JUSTIFY("",5)_"Enter Medical Hx Comments Menu added to RCIS Edit Menu")
+12 DO MES^XPDUTL("END updating option.")
+13 QUIT
+14 ; ------------------------------------------------------
P7 ;Adding new Report menu option for the printed C32
+1 SET BMC="BMC*4.0*7"
IF $$INSTALLD^BMC4P0(BMC)
QUIT
+2 DO BMES^XPDUTL("Begin adding option for Active referrals without a printed C32.")
+3 IF $$ADD^XPDMENU("BMC MENU-RPTS ADMINISTRATIVE","BMC RPT-ACTIVE REFERRALS-C32","ARC")
DO MES^XPDUTL($JUSTIFY("",5)_"Report for Active ref w/o a C32 Menu added to Adm Report option")
+4 DO MES^XPDUTL("END updating option.")
+5 QUIT
+6 ; ------------------------------------------------------
P8 ;Adding new Report menu option for TOC and Edit option for TOC
+1 SET BMC="BMC*4.0*8"
+2 IF $$INSTALLD^BMC4P0(BMC)
GOTO PCCLNK
+3 DO BMES^XPDUTL("Begin adding option for TOC Report for Approved referrals pending a TOC document.")
+4 IF $$ADD^XPDMENU("BMC MENU-RPTS ADMINISTRATIVE","BMC RPT-APPRV REF TOC PENDING","TOCR")
DO MES^XPDUTL($JUSTIFY("",5)_"Report for Approved ref w/o a TOC option added to Adm Report option")
+5 DO BMES^XPDUTL("Begin adding Edit option for TOC Information.")
+6 IF $$ADD^XPDMENU("BMC MENU EDIT REFERRAL","BMC MOD TOC","TOC")
DO MES^XPDUTL($JUSTIFY("",5)_"Edit Option for TOC information for Approved Referrals.")
+7 DO MES^XPDUTL("END updating option.")
+8 ;
PCCLNK ;Add RCIS to PCC Visit Merge Utility
+1 ;NEW INDEX NEED TO REINDEX FOR BETA SITES
+2 SET DIK="^BMCREF("
SET DIK(1)="1309^VSTR"
DO ENALL^DIK
KILL DIK
+3 ;already exists
IF $DATA(^APCDLINK("B","REFERRED CARE INFORMATION SYST"))
Begin DoDot:1
+4 SET DA=0
SET DA=$ORDER(^APCDLINK("B","REFERRED CARE INFORMATION SYST",DA))
+5 SET DIE="^APCDLINK("
SET DR=".01///REFERRED CARE INFORMATION SYS;1///I $L($T(MRG^BMCPCCV))"
+6 DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+7 ;already exists
IF $DATA(^APCDLINK("B","REFERRED CARE INFORMATION SYS"))
QUIT
+8 DO BMES^XPDUTL("Adding RCIS to PCC Visit Merge Utility . . .")
+9 NEW DD,DO,DIC,DLAYGO,X,Y
+10 SET DIC="^APCDLINK("
SET DIC(0)="LE"
SET DLAYGO=9001002
+11 SET DIC("DR")=".02///BMC;1///I $L($T(MRG^BMCPCCV)) D MRG^BMCPCCV;3///I $L($T(DEL^BMCPCCV)) D DEL^BMCPCCV"
+12 SET X="REFERRED CARE INFORMATION SYS"
DO FILE^DICN
+13 QUIT
+14 ; ------------------------------------------------------
P9 ;Add Report menu options
+1 DO MES^XPDUTL("Begin updating Special Print Menu option.")
+2 IF $$ADD^XPDMENU("BMC MENU SPECIAL","BMC DISPLAY REFERRAL RECORD","DSP")
+3 IF $$ADD^XPDMENU("BMC MENU SPECIAL","BMC PRINT REFERRAL FORMS","PRF")
+4 IF $$ADD^XPDMENU("BMC MENU SPECIAL","BMC PRINT ROUTING SLIP","PRS")
+5 IF $$ADD^XPDMENU("BMC MENU SPECIAL","BMC MENU-PRINT REPORTS","RPT")
+6 DO MES^XPDUTL("END updating Special Print Menu option.")
+7 ;
