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

BMC4P7.m

Go to the documentation of this file.
  1. BMC4P7 ;IHS/OIT/FCJ - BMC 4.0 PATCH 7 ; 16 Feb 2011 2:54 PM
  1. ;;4.0;REFERRED CARE INFO SYSTEM;**7**;JAN 09, 2006;Build 3
  1. ;ORIGINAL ROUTINE FR BMC4P6
  1. ;
  1. I '$G(IOM) D HOME^%ZIS
  1. ;
  1. I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY(2) Q
  1. ;
  1. I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY(2) Q
  1. ;
  1. I '(DUZ(0)["@") W:'$D(ZTQUEUED) !,"DUZ(0) DOES NOT CONTAIN AN '@'." D SORRY(2) Q
  1. ;
  1. S X=$$GET1^DIQ(200,DUZ,.01)
  1. W !!,$$CJ^XLFSTR("Hello, "_$P(X,",",2)_" "_$P(X,","),IOM)
  1. W !!,$$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" V "_$P($T(+2),";",3)_".",IOM)
  1. ;
  1. NEW IORVON,IORVOFF
  1. S X="IORVON;IORVOFF"
  1. D ENDR^%ZISS
  1. ;
  1. I $$VCHK("BMC","4.0",2,"'=")
  1. I $$VCHK("XU","8.0",2,"<")
  1. I $$VCHK("DI","22.0",2,"<")
  1. I '$$INSTALLD("AUPN*99.1*16") S BMCQUIT=2 D SORRY(BMCQUIT)
  1. I '$$INSTALLD("ATX*5.1*5") S BMCQUIT=2 D SORRY(BMCQUIT)
  1. I '$$INSTALLD("AUT*98.1*20") S BMCQUIT=2 D SORRY(BMCQUIT)
  1. I $$VCHK("LEX","2.0",2,"<")
  1. I '$$INSTALLD("AICD*3.51*7") S BMCQUIT=2 D SORRY(BMCQUIT)
  1. I '$$INSTALLD("OR*3.0*190") S BMCQUIT=2 D SORRY(BMCQUIT)
  1. I '$$VCHK("BQI","2.0",2,"<")
  1. I '$O(^DIC(19,"B","AGGRPC","")) W !!,"AGG GUI REGISTRATION 1.0 not installed" S BMCQUIT=2 D SORRY(BMCQUIT)
  1. E W !," AGG GUI REGISTRATION ..... Present"
  1. ;
  1. NEW DA,DIC
  1. S X="BMC",DIC="^DIC(9.4,",DIC(0)="",D="C"
  1. D IX^DIC
  1. I Y<0,$D(^DIC(9.4,"C","BMC")) D
  1. . W !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""BMC"" prefix.",IOM)
  1. . W !,$$CJ^XLFSTR(IORVON_"One entry needs to be deleted."_IORVOFF,IOM)
  1. . D SORRY(2)
  1. ;
  1. I $G(XPDQUIT) W !,$$CJ^XLFSTR(IORVON_"You will need to update package(s) before proceeding."_IORVOFF,IOM),!!,*7,*7,*7 Q
  1. W !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
  1. D HELP^XBHELP("INTROE","BMC4P7")
  1. I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2) Q
  1. I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0 D HELP^XBHELP("INTROI","BMC4P7") I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2)
  1. Q
  1. ;
  1. SORRY(X) ;
  1. KILL DIFQ
  1. S XPDQUIT=X
  1. W *7,!,$$CJ^XLFSTR("Sorry....Need to update package!",IOM)
  1. Q
  1. ;
  1. VCHK(BMCPRE,BMCVER,BMCQUIT,BMCCOMP) ; Check versions needed.
  1. ;
  1. NEW BMCV
  1. S BMCV=$$VERSION^XPDUTL(BMCPRE)
  1. W !,$$CJ^XLFSTR("Need "_$S(BMCCOMP="<":"at least ",1:"")_BMCPRE_" v "_BMCVER_"....."_BMCPRE_" v "_BMCV_" Present",IOM)
  1. I @(BMCV_BMCCOMP_BMCVER) D SORRY(BMCQUIT) Q 0
  1. Q 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. ;
  1. NEW DIC,X,Y,P
  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. I Y<1 S P=DIC_"""B"","_X_")" I $O(@P)'="" S Y=1
  1. I Y>0 W !,$$CJ^XLFSTR("Need at least "_BMC_"....."_BMC_" Present",IOM)
  1. I Y<0 W !,$$CJ^XLFSTR("Need at least "_BMC_".....",IOM)
  1. Q $S(Y<1:0,1:1)
  1. ;
  1. ; -----------------------------------------------------
  1. PRE ;EP - From KIDS.
  1. I $$NEWCP^XPDUTL("PRE1","AUDS^BMC4P7")
  1. ; The following line prevents the "Disable Options..." and "Move
  1. ; Routines..." questions from being asked during the install.
  1. I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
  1. Q
  1. ;
  1. POST ;EP - From KIDS.
  1. ; --- Restore dd audit settings.
  1. S %="AUDR^BMC4P7"
  1. I $$NEWCP^XPDUTL("POS1-"_%,%)
  1. ;
  1. ; --- Set new Index "BA" and "BB"
  1. S %="INDX^BMC4P7"
  1. I $$NEWCP^XPDUTL("POS2-"_%,%)
  1. ;
  1. ; --- Add Provider/Vendor Option
  1. S %="P5^BMC4P7"
  1. I $$NEWCP^XPDUTL("POS3-"_%,%)
  1. ;
  1. ; --- Add MED HX Option and fx CHS 2010 PO #'s
  1. S %="P6^BMC4P7"
  1. I $$NEWCP^XPDUTL("POS4-"_%,%)
  1. ;
  1. ; --- Add Report Option for printing C32s for Active referrals
  1. S %="P7^BMC4P7"
  1. I $$NEWCP^XPDUTL("POS5-"_%,%)
  1. ;
  1. ; --- Send mail message of install.
  1. S %="MAIL^BMC4P7"
  1. I $$NEWCP^XPDUTL("POS6-"_%,%)
  1. ;
  1. Q
  1. ;
  1. MAIL ;
  1. D BMES^XPDUTL("BEGIN Delivering MailMan message to select users.")
  1. NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
  1. KILL ^TMP("BMC4P7",$J)
  1. D RSLT(" --- BMC v 4.0 Patch 1, 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(""BMC4P7"",$J,",XMY(1)="",XMY(DUZ)=""
  1. F %="BMCZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
  1. D ^XMD
  1. KILL ^TMP("BMC4P7",$J)
  1. D MES^XPDUTL("END Delivering MailMan message to select users.")
  1. Q
  1. ;
  1. RSLT(%) S ^(0)=$G(^TMP("BMC4P7",$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. INTROE ; Intro text during KIDS Environment check.
  1. ;;In this distribution:
  1. ;;(1) Added new C32 Report option to print Referrals that do not have
  1. ;; a C32 printed. Option is located under the Administrative reports
  1. ;; option.
  1. ;;(2) Additional routines for the EHR RCIS provider interface.
  1. ;;
  1. ;;
  1. ;;###
  1. ;
  1. INTROI ; Intro text during KIDS Install.
  1. ;;A standard message will be produced by this update.
  1. ;;
  1. ;;If you run interactively, results will be displayed on your screen,
  1. ;;as well as in the mail message and the entry in the INSTALL file.
  1. ;;If you queue to TaskMan, please read the mail message for results of
  1. ;;this update, and remember not to Q to the HOME device.
  1. ;;###
  1. ;
  1. GREET ;;To add to mail message.
  1. ;;
  1. ;;Greetings.
  1. ;;
  1. ;;The RCIS package on your RPMS system has 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 patch, which is a product of the RPMS developer
  1. ;;(Fonda Jackson at 971.235.5714),
  1. ;;can be directed to the DIR/RPMS Support Center, at 505-248-4371,
  1. ;;or via e-mail to "oithelp@ihs.gov".
  1. ;;Please refer to patch "bmc*4.0*6".
  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. AUDS ;EP - From KIDS.
  1. D BMES^XPDUTL("Saving current DD AUDIT settings for files in this patch")
  1. D MES^XPDUTL("and turning DD AUDIT to 'Y'.")
  1. S ^XTMP("BMC4P7",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^"_$P($P($T(+1),";",2)," ",3,99)
  1. NEW BMC
  1. S BMC=0
  1. F S BMC=$O(^XTMP("XPDI",XPDA,"FIA",BMC)) Q:'BMC D
  1. . I '$D(^XTMP("BMC4P7",BMC,"DDA")) S ^XTMP("BMC4P7",BMC,"DDA")=$G(^DD(BMC,0,"DDA"))
  1. . D MES^XPDUTL(" File "_$$RJ^XLFSTR(BMC,12)_" - "_$$LJ^XLFSTR(^XTMP("XPDI",XPDA,"FIA",BMC),30)_"- DD audit was '"_$G(^XTMP("BMC4P7",BMC,"DDA"))_"'"),MES^XPDUTL($$RJ^XLFSTR("Set to 'Y'",69))
  1. . S ^DD(BMC,0,"DDA")="Y"
  1. .Q
  1. D MES^XPDUTL("DD AUDIT settings saved in ^XTMP(.")
  1. Q
  1. ; -----------------------------------------------------
  1. AUDR ; Restore the file data audit values to their original values.
  1. D BMES^XPDUTL("Restoring DD AUDIT settings for files in this patch.")
  1. NEW BMC
  1. S BMC=0
  1. F S BMC=$O(^XTMP("BMC4P7",BMC)) Q:'BMC D
  1. . S ^DD(BMC,0,"DDA")=^XTMP("BMC4P7",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("BMC4P7")
  1. D MES^XPDUTL("DD AUDIT settings restored.")
  1. Q
  1. ; -----------------------------------------------------
  1. INDX ;INDEX NEW INDECIES "BA", "BB" AND "CD" ;Patch 2
  1. S BMC="BMC*4.0*2" Q:$$INSTALLD^BMC4P0(BMC)
  1. D BMES^XPDUTL("BEGIN Indexing Expected Begining Date of Service.")
  1. S DIK="^BMCREF("
  1. S DIK(1)="1105^BA"
  1. D ENALL^DIK
  1. D BMES^XPDUTL("BEGIN Indexing Actual Appointment/begin DOS.")
  1. S DIK(1)="1106^BB"
  1. D ENALL^DIK
  1. D BMES^XPDUTL("BEGIN Indexing CHS Denial Number.")
  1. S DIK(1)="1128^CD"
  1. D ENALL^DIK
  1. D BMES^XPDUTL("Completed updating new indexes.")
  1. K DA,DIC,DIK,X
  1. Q
  1. ; -----------------------------------------------------
  1. P5 ;Add Menu option for Vendor
  1. S BMC="BMC*4.0*5" Q:$$INSTALLD^BMC4P0(BMC)
  1. D BMES^XPDUTL("Begin adding new Provider/Vendor option.")
  1. I $$ADD^XPDMENU("BMCMENU","BMCVEN","VEN") D MES^XPDUTL($J("",5)_"Provider/Vendor add/edit Menu added to RCIS Main Menu")
  1. D MES^XPDUTL("END updating option.")
  1. Q
  1. ; -----------------------------------------------------
  1. P6 ;FX CHS PO'S WITH FY 00 INSTEAD OF FY 10
  1. S BMC="BMC*4.0*6" Q:$$INSTALLD^BMC4P0(BMC)
  1. D MES^XPDUTL("Updating CHS 2010 PO Numbers.")
  1. S BMC=3090900 F S BMC=$O(^BMCREF("B",BMC)) Q:BMC'?1N.N D
  1. .S BMC1="" F S BMC1=$O(^BMCREF("B",BMC,BMC1)) Q:BMC1'?1N.N D
  1. ..I $D(^BMCREF(BMC1,41)) S BMC2=0 F S BMC2=$O(^BMCREF(BMC1,41,BMC2)) Q:BMC2'?1N.N D
  1. ...S BMCPO=$P(^BMCREF(BMC1,41,BMC2,0),U,8)
  1. ...I $E(BMCPO,1,2)="00",$L(BMCPO)=12 D
  1. ....S $P(^BMCREF(BMC1,41,BMC2,0),U,8)="10"_$E(BMCPO,3,12)
  1. ....S $P(^BMCREF(BMC1,41,BMC2,11),U)=10
  1. D BMES^XPDUTL("Begin adding option for Adding Med Hx comments.")
  1. 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")
  1. D MES^XPDUTL("END updating option.")
  1. Q
  1. ; ------------------------------------------------------
  1. P7 ;Adding new Report menu option for the printed C32
  1. S BMC="BMC*4.0*7" Q:$$INSTALLD^BMC4P0(BMC)
  1. D BMES^XPDUTL("Begin adding option for Active referrals without a printed C32.")
  1. 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")
  1. D MES^XPDUTL("END updating option.")
  1. Q
  1. ; ------------------------------------------------------