BMC4P12 ;IHS/OIT/FCJ - BMC 4.0 PATCH 12 ; 16 Feb 2011 2:54 PM
;;4.0;REFERRED CARE INFO SYSTEM;**12**;JAN 09, 2006;Build 92
;
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^BMC4P12("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","BMC4E")
I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2) Q
I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0 D HELP^XBHELP("INTROI","BMC4E") 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^BMC4E")
; 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.
;Add BUSA entries
I $D(^BUSA(9002319.03,0)) D
. ;BMC ADD REFERRAL
. I $O(^BUSA(9002319.03,"B","BMC ADD REFERRAL",""))="" D
.. NEW DIC,X,DLAYGO,Y,DTOUT,DIRUT,DUOUT,BUSAUPD,DA,ERROR
.. S DIC(0)="L",DIC="^BUSA(9002319.03,"
.. L +^BUSA(9002319.03,0):1 E Q
.. S X="BMC ADD REFERRAL",DLAYGO=9002319.03
.. K DO,DD D FILE^DICN
.. L -^BUSA(9002319.03,0)
.. I +Y<0 Q
.. S DA=+Y
.. S BUSAUPD(9002319.03,DA_",",.02)="P",BUSAUPD(9002319.03,DA_",",.03)="A"
.. S BUSAUPD(9002319.03,DA_",",.06)="S X=""BMC: Created patient referral"""
.. S BUSAUPD(9002319.03,DA_",",1.01)="I~2",BUSAUPD(9002319.03,DA_",",2.01)="I~32"
.. D FILE^DIE("","BUSAUPD","ERROR")
. ;BMC UPDATE REFERRAL
. I $O(^BUSA(9002319.03,"B","BMC UPDATE REFERRAL",""))="" D
.. NEW DIC,X,DLAYGO,Y,DTOUT,DIRUT,DUOUT,BUSAUPD,DA,ERROR
.. S DIC(0)="L",DIC="^BUSA(9002319.03,"
.. L +^BUSA(9002319.03,0):1 E Q
.. S X="BMC UPDATE REFERRAL",DLAYGO=9002319.03
.. K DO,DD D FILE^DICN
.. L -^BUSA(9002319.03,0)
.. I +Y<0 Q
.. S DA=+Y
.. S BUSAUPD(9002319.03,DA_",",.02)="P",BUSAUPD(9002319.03,DA_",",.03)="E"
.. S BUSAUPD(9002319.03,DA_",",.06)="S X=""BMC: Update patient referral"""
.. S BUSAUPD(9002319.03,DA_",",1.01)="I~1"
.. S BUSAUPD(9002319.03,DA_",",1.02)="S X=$$GET1~DIQ(90001,X_"","",.03,""I"")"
.. S BUSAUPD(9002319.03,DA_",",2.01)="I~1"
.. S BUSAUPD(9002319.03,DA_",",2.02)="S X=$$GET1~DIQ(90001,X_"","",1309,""I"")"
.. D FILE^DIE("","BUSAUPD","ERROR")
;
; --- Restore dd audit settings.
S %="AUDR^BMC4E"
I $$NEWCP^XPDUTL("POS1-"_%,%)
; --- Set new Index "BA" and "BB"
S %="INDX^BMC4P12"
I $$NEWCP^XPDUTL("POS2-"_%,%)
; --- Add Provider/Vendor Option
S %="P5^BMC4P12"
I $$NEWCP^XPDUTL("POS3-"_%,%)
; --- Add MED HX Opt and fx CHS 2010 PO #'s
S %="P6^BMC4P12"
I $$NEWCP^XPDUTL("POS4-"_%,%)
; --- Add Opt-printing C32s for Active referrals
S %="P7^BMC4P12"
I $$NEWCP^XPDUTL("POS5-"_%,%)
; --- Add Opt-TOC and Edit option for TOC
S %="P8^BMC4P12"
I $$NEWCP^XPDUTL("POS6-"_%,%)
; ---Re-Add Options, removed because a parent opt sent
S %="P9^BMC4P12"
I $$NEWCP^XPDUTL("POS8-"_%,%)
; ---Remove CHS PAID from GEN RET
S %="P10^BMC4P12"
I $$NEWCP^XPDUTL("POS9-"_%,%)
; ---Remove clinic field from V ref file
S %="P10VR^BMC4P12"
I $$NEWCP^XPDUTL("POS10-"_%,%)
; ---Reformat comments to 80 char in RCIS Comments file
S %="P10COM^BMC4P12"
I $$NEWCP^XPDUTL("POS11-"_%,%)
; ---New Opt and fix of V Ref file
S %="P12^BMC4P12"
I $$NEWCP^XPDUTL("POS12-"_%,%)
; --- Send mail message of install.
S %="MAIL^BMC4E"
I $$NEWCP^XPDUTL("POS13-"_%,%)
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 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 Opt 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 ;Add Report opt 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 ;Add Report TOC Opt and Edit TOC Opt
S BMC="BMC*4.0*8" Q:$$INSTALLD^BMC4P0(BMC)
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 Opt
S BMC="BMC*4.0*9" ;Q:$$INSTALLD^BMC4P0(BMC)
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.")
Q
P10 ;Patch 10
;S BMC="BMC*4.0*10" Q:$$INSTALLD^BMC4P0(BMC)
;Delete GEN RET option 99.1 CHS Paid To Date
NEW DA,DIE,DIC,DR
S X="CHS Paid To Date",(DIC,DIE)="^BMCTSORT(",DR=".01////"_"@"
D ^DIC
I +Y<0 D BMES^XPDUTL("Unable to remove CHS Paid To Date from Gen Ret items . . .")
S DA=+Y
D ^DIE
D BMES^XPDUTL("CHS Paid To Date removed from Gen Ret items . . .")
Q
;
P10VR ;Clean up clinic stop in V Referral file
S BMC="BMC*4.0*10" Q:$$INSTALLD^BMC4P0(BMC)
NEW DA,DIE,DIC,DR
S DA=0
S DIE="^AUPNVREF(",DR="1203////"_"@"
F S DA=$O(^AUPNVREF(DA)) Q:DA'?1N.N D:$P($G(^AUPNVREF(DA,12)),U,3)'=""
.D ^DIE
D BMES^XPDUTL("Completed clean up of clinic stop field in V Referral file . . .")
Q
P10COM ;Clean up of comments file
S BMC="BMC*4.0*10" Q:$$INSTALLD^BMC4P0(BMC)
NEW DA,DIE,DIC,DR
S BEGDT=3130100
F S BEGDT=$O(^BMCCOM("B",BEGDT)) Q:BEGDT'?1N.N D
.S DA=0
.F S DA=$O(^BMCCOM("B",BEGDT,DA)) Q:DA'?1N.N D
..Q:'$D(^BMCCOM(DA,1,0))
..S DA(1)=0,FLG=0 F S DA(1)=$O(^BMCCOM(DA,1,DA(1))) Q:DA(1)'?1N.N I $L(^BMCCOM(DA,1,DA(1),0))>80 S FLG=1
..Q:FLG'=1
..S DA(1)=0 F S DA(1)=$O(^BMCCOM(DA,1,DA(1))) Q:DA(1)'?1N.N D
...S ^BMCCOMT(DA,1,DA(1),0)=^BMCCOM(DA,1,DA(1),0)
..S ^BMCCOMT(DA,1,0)=^BMCCOM(DA,1,0),BMCDA=(DA(1)-1)
..K ^BMCCOM(DA,1)
..S BMCDA=0,BMCDA2=0
..F S BMCDA=$O(^BMCCOMT(DA,1,BMCDA)) Q:BMCDA'?1N.N D
...S BMCCOM=^BMCCOMT(DA,1,BMCDA,0)
...S L=($L(BMCCOM)/80) I L#1>0 S L=L+1
...S (LGTH,LGTH2)=0 F I=1:1:L D
....S LGTH=LGTH2+1,BMCDA2=BMCDA2+1,LGTH2=80*BMCDA2 S ^BMCCOM(DA,1,BMCDA2,0)=$E(BMCCOM,LGTH,LGTH2)
...S ^BMCCOM(DA,1,0)=^BMCCOMT(DA,1,0),$P(^BMCCOM(DA,1,0),U,2,4)="90001.031"_U_BMCDA2_U_BMCDA2
K L,LGTH,LGHT2,BMCDA,BMCDA2,BMCCOM,FLG,BEGDT,CT
D BMES^XPDUTL("Completed clean up RCIS Comments file . . .")
Q
;
P12 ;Add Report Opt and Call-in options
;S BMC="BMC*4.0*12" Q:$$INSTALLD^BMC4P0(BMC)
D BMES^XPDUTL("Begin adding option for CHS Paid Report.")
I $$ADD^XPDMENU("BMC MENU-RPTS ADMINISTRATIVE","BMC RPT-CHS ONLY PAID","CHSP") D MES^XPDUTL($J("",5)_"Report for CHS Paid Referrals option added to Adm Report option")
D BMES^XPDUTL("Begin adding Edit option for Call-in Referrals.")
I $$ADD^XPDMENU("BMC MENU REFERRAL MANAGEMENT","BMC CALL-IN REFERRAL EDIT","CIN") D MES^XPDUTL($J("",5)_"Edit Call in Referrals added to Referral Management Menu.")
D MES^XPDUTL("END updating option.")
VREF ;CLEAN UP V REF FILE
G:$G(^AUPNVREF(0)) ZPAR
D BMES^XPDUTL("Updating V Referral file.")
;FIX TO STUFF 1202 OF V REFERRAL WITH REQUESTING PROVIDER FROM RCIS REFERRAL ENTRY
;NULL OUT 1210 FIELD VALUE
;MOVE AND CORRECT V REFERRAL INFO BASED ON REFERRAL ENTRY
NEW APCDVREF,APCDREF,APCDRP,BMCVDFN,BMCVPRV
S APCDVREF=0 F S APCDVREF=$O(^AUPNVREF(APCDVREF)) Q:APCDVREF'=+APCDVREF D
.S APCDREF=$$VALI^XBDIQ1(9000010.59,APCDVREF,.06)
.Q:APCDREF="" ;NO REFERRAL IEN
.Q:'$D(^BMCREF(APCDREF,0)) ;no referral??
.S APCDRP=$$VALI^XBDIQ1(90001,APCDREF,.06) ;REQUESTING PROVIDER IEN
.S (BMCVDFN,BMCVPRV)="",BMCVDFN=$$VALI^XBDIQ1(90001,APCDREF,1309) I BMCVDFN S BMCVPRV=$$PRIMPROV^APCLV(BMCVDFN,"I")
.S DIE="^AUPNVREF(",DA=APCDVREF
.I APCDRP S DR="1210///@;1202////"_APCDRP
.I 'APCDRP S DR="1210///@;1202///@"
.I BMCVPRV S DR=DR_";1204////"_BMCVPRV ;SET PROV ENCOUNTER
.D ^DIE
.I $D(Y) D EN^DDIOL("failure to update v referral "_APCDVREF)
.K DIE,DA,DR
D BMES^XPDUTL("Completed Updating V Referral file.")
ZPAR ;ADD ENTRY TO ZISH PARAMETER FILE
D BMES^XPDUTL("Adding entry to Zish Send Parameter file.")
S X="BMC RCIS REPORTS",DIC="^%ZIB(9888888.93,",DIC(0)="L"
D ^DIC
I Y<0 W !,"ZISH SEND PARAMETER FOR THE BMC RCIS REPORTS ENTRY COULD NOT BE ADDED, YOU WILL NEED ADD THROUGH FILEMAN" G GENRET
S DA=+Y,DIE=DIC
S DR=".07////"_"B"_";.08////"_"sendto"
D ^DIE
K D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM,DA
D BMES^XPDUTL("Completed adding Entry to Zish Send Parameter file.")
;
GENRET ;UPDATE GEN RET OPTIONS
D BMES^XPDUTL("Updating items for the Gen Ret Report option.")
NEW DA,DIE,DIC,DR
S X="Service Category (CPT)",(DIC,DIE)="^BMCTSORT(",DR=".01////Service Cat HCPCS/CPT"
D ^DIC I +Y>0 S DA=+Y D ^DIE K DR
S X="Util Review Committee",DR=".09////952"
D ^DIC I +Y>0 S DA=+Y D ^DIE K DR
S X="Mgd Care Committee",DR=".09////950"
D ^DIC I +Y>0 S DA=+Y D ^DIE K DR
S X="DT Mgd Care Action",DR=".09////951"
D ^DIC I +Y>0 S DA=+Y D ^DIE K DR
S X="Site Created by" D ^DIC I +Y<0 S DIC(0)="L" D
.D ^DIC S DA=+Y
.S DR=".02////R;.04////90001.31,.01;.05////S;.06////Site Created by;.07////20;.09////999;.11////R;"
.S DR=DR_"1////S X=$$FACREQ^BMCRLU1(BMCREF);2////S X=$P(^DIC(4,BMCY,0),U)"
.D ^DIE
D BMES^XPDUTL("Completed updating items for the Gen Ret option . . .")
K DA,DIE,DIC,DR
Q
BMC4P12 ;IHS/OIT/FCJ - BMC 4.0 PATCH 12 ; 16 Feb 2011 2:54 PM
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**12**;JAN 09, 2006;Build 92
+2 ;
+3 IF '$GET(IOM)
DO HOME^%ZIS
+4 IF '$GET(DUZ)
WRITE !,"DUZ UNDEFINED OR 0."
DO SORRY(2)
QUIT
+5 IF '$LENGTH($GET(DUZ(0)))
WRITE !,"DUZ(0) UNDEFINED OR NULL."
DO SORRY(2)
QUIT
+6 IF '(DUZ(0)["@")
IF '$DATA(ZTQUEUED)
WRITE !,"DUZ(0) DOES NOT CONTAIN AN '@'."
DO SORRY(2)
QUIT
+7 ;
+8 SET X=$$GET1^DIQ(200,DUZ,.01)
+9 WRITE !!,$$CJ^XLFSTR("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","),IOM)
+10 WRITE !!,$$CJ^XLFSTR("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_$PIECE($TEXT(+2),";",3)_".",IOM),!
+11 ;
+12 NEW IORVON,IORVOFF
+13 SET X="IORVON;IORVOFF"
+14 DO ENDR^%ZISS
+15 ;
+16 IF $$VCHK("BMC","4.0",2,"'=")
+17 IF $$VCHK("DI","22.0",2,"<")
+18 IF $$VCHK("XU","8.0",2,"<")
+19 IF $$VCHK^BMC4P12("AICD","4.0",2,"<")
+20 IF '$$INSTALLD("AG*7.1*11")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
+21 IF '$$INSTALLD("AUPN*99.1*16")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
+22 IF '$$INSTALLD("ATX*5.1*5")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
+23 IF '$$INSTALLD("AUT*98.1*26")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
+24 IF '$$INSTALLD("LEX*2.0*1003")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
+25 IF '$$INSTALLD("OR*3.0*190")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
+26 IF $$VCHK("BSTS","1.0",2,"'=")
+27 WRITE !!
+28 SET DIR(0)="Y0"
SET DIR("A")="Is the Facility using PCC"
DO ^DIR
+29 IF +Y>0
IF '$$INSTALLD("BJPC*2.0*10")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
+30 WRITE !
+31 SET DIR(0)="Y0"
SET DIR("A")="Is the Facility using EHR"
DO ^DIR
+32 IF +Y>0
IF '$$INSTALLD("BGO*1.1*13")
SET BMCQUIT=2
DO SORRY(BMCQUIT)
WRITE !
+33 ;
+34 NEW DA,DIC
+35 SET X="BMC"
SET DIC="^DIC(9.4,"
SET DIC(0)=""
SET D="C"
+36 DO IX^DIC
+37 IF Y<0
IF $DATA(^DIC(9.4,"C","BMC"))
Begin DoDot:1
+38 WRITE !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""BMC"" prefix.",IOM)
+39 WRITE !,$$CJ^XLFSTR(IORVON_"One entry needs to be deleted."_IORVOFF,IOM)
+40 DO SORRY(2)
End DoDot:1
+41 ;
+42 IF $GET(XPDQUIT)
WRITE !,$$CJ^XLFSTR(IORVON_"You will need to update package(s) before proceeding."_IORVOFF,IOM),!!,*7,*7,*7
QUIT
+43 WRITE !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
+44 DO HELP^XBHELP("INTROE","BMC4E")
+45 IF '$$DIR^XBDIR("E","","","","","",1)
DO SORRY(2)
QUIT
+46 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
DO HELP^XBHELP("INTROI","BMC4E")
IF '$$DIR^XBDIR("E","","","","","",1)
DO SORRY(2)
+47 QUIT
+48 ;
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 NEW BMCV
+2 SET BMCV=$$VERSION^XPDUTL(BMCPRE)
+3 IF BMCV=""
Begin DoDot:1
+4 WRITE !,$$CJ^XLFSTR("Need "_$SELECT(BMCCOMP="<":"at least ",1:"")_BMCPRE_" v "_BMCVER_"....."_BMCPRE_" v "_BMCV_" Not Present",IOM)
+5 DO SORRY(BMCQUIT)
End DoDot:1
QUIT 0
+6 WRITE !,$$CJ^XLFSTR("Need "_$SELECT(BMCCOMP="<":"at least ",1:"")_BMCPRE_" v "_BMCVER_"....."_BMCPRE_" v "_BMCV_" Present",IOM)
+7 IF @(BMCV_BMCCOMP_BMCVER)
DO SORRY(BMCQUIT)
QUIT 0
+8 QUIT 1
+9 ;
INSTALLD(BMC) ; Determine if patch BMC was installed, where BMC is
+1 ; the name of the INSTALL. E.g "AVA*93.2*12".
+2 NEW DIC,X,Y,P
+3 ; lookup package.
+4 SET X=$PIECE(BMC,"*",1)
+5 SET DIC="^DIC(9.4,"
SET DIC(0)="FM"
SET D="C"
+6 DO IX^DIC
+7 IF Y<1
QUIT 0
+8 ; lookup version.
+9 SET DIC=DIC_+Y_",22,"
SET X=$PIECE(BMC,"*",2)
+10 DO ^DIC
+11 IF Y<1
QUIT 0
+12 ; lookup patch.
+13 SET DIC=DIC_+Y_",""PAH"","
SET X=$PIECE(BMC,"*",3)
+14 DO ^DIC
+15 IF Y<1
SET P=DIC_"""B"","_X_")"
IF $ORDER(@P)'=""
SET Y=1
+16 IF Y>0
WRITE !,$$CJ^XLFSTR("Need at least "_BMC_"....."_BMC_" Present",IOM)
+17 IF Y<0
WRITE !,$$CJ^XLFSTR("Need at least "_BMC_".....",IOM)
+18 QUIT $SELECT(Y<1:0,1:1)
+19 ;
PRE ;EP - From KIDS.
+1 IF $$NEWCP^XPDUTL("PRE1","AUDS^BMC4E")
+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 ;Add BUSA entries
+2 IF $DATA(^BUSA(9002319.03,0))
Begin DoDot:1
+3 ;BMC ADD REFERRAL
+4 IF $ORDER(^BUSA(9002319.03,"B","BMC ADD REFERRAL",""))=""
Begin DoDot:2
+5 NEW DIC,X,DLAYGO,Y,DTOUT,DIRUT,DUOUT,BUSAUPD,DA,ERROR
+6 SET DIC(0)="L"
SET DIC="^BUSA(9002319.03,"
+7 LOCK +^BUSA(9002319.03,0):1
IF '$TEST
QUIT
+8 SET X="BMC ADD REFERRAL"
SET DLAYGO=9002319.03
+9 KILL DO,DD
DO FILE^DICN
+10 LOCK -^BUSA(9002319.03,0)
+11 IF +Y<0
QUIT
+12 SET DA=+Y
+13 SET BUSAUPD(9002319.03,DA_",",.02)="P"
SET BUSAUPD(9002319.03,DA_",",.03)="A"
+14 SET BUSAUPD(9002319.03,DA_",",.06)="S X=""BMC: Created patient referral"""
+15 SET BUSAUPD(9002319.03,DA_",",1.01)="I~2"
SET BUSAUPD(9002319.03,DA_",",2.01)="I~32"
+16 DO FILE^DIE("","BUSAUPD","ERROR")
End DoDot:2
+17 ;BMC UPDATE REFERRAL
+18 IF $ORDER(^BUSA(9002319.03,"B","BMC UPDATE REFERRAL",""))=""
Begin DoDot:2
+19 NEW DIC,X,DLAYGO,Y,DTOUT,DIRUT,DUOUT,BUSAUPD,DA,ERROR
+20 SET DIC(0)="L"
SET DIC="^BUSA(9002319.03,"
+21 LOCK +^BUSA(9002319.03,0):1
IF '$TEST
QUIT
+22 SET X="BMC UPDATE REFERRAL"
SET DLAYGO=9002319.03
+23 KILL DO,DD
DO FILE^DICN
+24 LOCK -^BUSA(9002319.03,0)
+25 IF +Y<0
QUIT
+26 SET DA=+Y
+27 SET BUSAUPD(9002319.03,DA_",",.02)="P"
SET BUSAUPD(9002319.03,DA_",",.03)="E"
+28 SET BUSAUPD(9002319.03,DA_",",.06)="S X=""BMC: Update patient referral"""
+29 SET BUSAUPD(9002319.03,DA_",",1.01)="I~1"
+30 SET BUSAUPD(9002319.03,DA_",",1.02)="S X=$$GET1~DIQ(90001,X_"","",.03,""I"")"
+31 SET BUSAUPD(9002319.03,DA_",",2.01)="I~1"
+32 SET BUSAUPD(9002319.03,DA_",",2.02)="S X=$$GET1~DIQ(90001,X_"","",1309,""I"")"
+33 DO FILE^DIE("","BUSAUPD","ERROR")
End DoDot:2
End DoDot:1
+34 ;
+35 ; --- Restore dd audit settings.
+36 SET %="AUDR^BMC4E"
+37 IF $$NEWCP^XPDUTL("POS1-"_%,%)
+38 ; --- Set new Index "BA" and "BB"
+39 SET %="INDX^BMC4P12"
+40 IF $$NEWCP^XPDUTL("POS2-"_%,%)
+41 ; --- Add Provider/Vendor Option
+42 SET %="P5^BMC4P12"
+43 IF $$NEWCP^XPDUTL("POS3-"_%,%)
+44 ; --- Add MED HX Opt and fx CHS 2010 PO #'s
+45 SET %="P6^BMC4P12"
+46 IF $$NEWCP^XPDUTL("POS4-"_%,%)
+47 ; --- Add Opt-printing C32s for Active referrals
+48 SET %="P7^BMC4P12"
+49 IF $$NEWCP^XPDUTL("POS5-"_%,%)
+50 ; --- Add Opt-TOC and Edit option for TOC
+51 SET %="P8^BMC4P12"
+52 IF $$NEWCP^XPDUTL("POS6-"_%,%)
+53 ; ---Re-Add Options, removed because a parent opt sent
+54 SET %="P9^BMC4P12"
+55 IF $$NEWCP^XPDUTL("POS8-"_%,%)
+56 ; ---Remove CHS PAID from GEN RET
+57 SET %="P10^BMC4P12"
+58 IF $$NEWCP^XPDUTL("POS9-"_%,%)
+59 ; ---Remove clinic field from V ref file
+60 SET %="P10VR^BMC4P12"
+61 IF $$NEWCP^XPDUTL("POS10-"_%,%)
+62 ; ---Reformat comments to 80 char in RCIS Comments file
+63 SET %="P10COM^BMC4P12"
+64 IF $$NEWCP^XPDUTL("POS11-"_%,%)
+65 ; ---New Opt and fix of V Ref file
+66 SET %="P12^BMC4P12"
+67 IF $$NEWCP^XPDUTL("POS12-"_%,%)
+68 ; --- Send mail message of install.
+69 SET %="MAIL^BMC4E"
+70 IF $$NEWCP^XPDUTL("POS13-"_%,%)
+71 QUIT
+72 ;
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 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
P5 ;Add Opt 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
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
P7 ;Add Report opt 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
P8 ;Add Report TOC Opt and Edit TOC Opt
+1 SET BMC="BMC*4.0*8"
IF $$INSTALLD^BMC4P0(BMC)
QUIT
+2 DO BMES^XPDUTL("Begin adding option for TOC Report for Approved referrals pending a TOC document.")
+3 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")
+4 DO BMES^XPDUTL("Begin adding Edit option for TOC Information.")
+5 IF $$ADD^XPDMENU("BMC MENU EDIT REFERRAL","BMC MOD TOC","TOC")
DO MES^XPDUTL($JUSTIFY("",5)_"Edit Option for TOC information for Approved Referrals.")
+6 DO MES^XPDUTL("END updating option.")
+7 ;
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
P9 ;Add Report Opt
+1 ;Q:$$INSTALLD^BMC4P0(BMC)
SET BMC="BMC*4.0*9"
+2 DO MES^XPDUTL("Begin updating Special Print Menu option.")
+3 IF $$ADD^XPDMENU("BMC MENU SPECIAL","BMC DISPLAY REFERRAL RECORD","DSP")
+4 IF $$ADD^XPDMENU("BMC MENU SPECIAL","BMC PRINT REFERRAL FORMS","PRF")
+5 IF $$ADD^XPDMENU("BMC MENU SPECIAL","BMC PRINT ROUTING SLIP","PRS")
+6 IF $$ADD^XPDMENU("BMC MENU SPECIAL","BMC MENU-PRINT REPORTS","RPT")
+7 DO MES^XPDUTL("END updating Special Print Menu option.")
+8 QUIT
P10 ;Patch 10
+1 ;S BMC="BMC*4.0*10" Q:$$INSTALLD^BMC4P0(BMC)
+2 ;Delete GEN RET option 99.1 CHS Paid To Date
+3 NEW DA,DIE,DIC,DR
+4 SET X="CHS Paid To Date"
SET (DIC,DIE)="^BMCTSORT("
SET DR=".01////"_"@"
+5 DO ^DIC
+6 IF +Y<0
DO BMES^XPDUTL("Unable to remove CHS Paid To Date from Gen Ret items . . .")
+7 SET DA=+Y
+8 DO ^DIE
+9 DO BMES^XPDUTL("CHS Paid To Date removed from Gen Ret items . . .")
+10 QUIT
+11 ;
P10VR ;Clean up clinic stop in V Referral file
+1 SET BMC="BMC*4.0*10"
IF $$INSTALLD^BMC4P0(BMC)
QUIT
+2 NEW DA,DIE,DIC,DR
+3 SET DA=0
+4 SET DIE="^AUPNVREF("
SET DR="1203////"_"@"
+5 FOR
SET DA=$ORDER(^AUPNVREF(DA))
IF DA'?1N.N
QUIT
IF $PIECE($GET(^AUPNVREF(DA,12)),U,3)'=""
Begin DoDot:1
+6 DO ^DIE
End DoDot:1
+7 DO BMES^XPDUTL("Completed clean up of clinic stop field in V Referral file . . .")
+8 QUIT
P10COM ;Clean up of comments file
+1 SET BMC="BMC*4.0*10"
IF $$INSTALLD^BMC4P0(BMC)
QUIT
+2 NEW DA,DIE,DIC,DR
+3 SET BEGDT=3130100
+4 FOR
SET BEGDT=$ORDER(^BMCCOM("B",BEGDT))
IF BEGDT'?1N.N
QUIT
Begin DoDot:1
+5 SET DA=0
+6 FOR
SET DA=$ORDER(^BMCCOM("B",BEGDT,DA))
IF DA'?1N.N
QUIT
Begin DoDot:2
+7 IF '$DATA(^BMCCOM(DA,1,0))
QUIT
+8 SET DA(1)=0
SET FLG=0
FOR
SET DA(1)=$ORDER(^BMCCOM(DA,1,DA(1)))
IF DA(1)'?1N.N
QUIT
IF $LENGTH(^BMCCOM(DA,1,DA(1),0))>80
SET FLG=1
+9 IF FLG'=1
QUIT
+10 SET DA(1)=0
FOR
SET DA(1)=$ORDER(^BMCCOM(DA,1,DA(1)))
IF DA(1)'?1N.N
QUIT
Begin DoDot:3
+11 SET ^BMCCOMT(DA,1,DA(1),0)=^BMCCOM(DA,1,DA(1),0)
End DoDot:3
+12 SET ^BMCCOMT(DA,1,0)=^BMCCOM(DA,1,0)
SET BMCDA=(DA(1)-1)
+13 KILL ^BMCCOM(DA,1)
+14 SET BMCDA=0
SET BMCDA2=0
+15 FOR
SET BMCDA=$ORDER(^BMCCOMT(DA,1,BMCDA))
IF BMCDA'?1N.N
QUIT
Begin DoDot:3
+16 SET BMCCOM=^BMCCOMT(DA,1,BMCDA,0)
+17 SET L=($LENGTH(BMCCOM)/80)
IF L#1>0
SET L=L+1
+18 SET (LGTH,LGTH2)=0
FOR I=1:1:L
Begin DoDot:4
+19 SET LGTH=LGTH2+1
SET BMCDA2=BMCDA2+1
SET LGTH2=80*BMCDA2
SET ^BMCCOM(DA,1,BMCDA2,0)=$EXTRACT(BMCCOM,LGTH,LGTH2)
End DoDot:4
+20 SET ^BMCCOM(DA,1,0)=^BMCCOMT(DA,1,0)
SET $PIECE(^BMCCOM(DA,1,0),U,2,4)="90001.031"_U_BMCDA2_U_BMCDA2
End DoDot:3
End DoDot:2
End DoDot:1
+21 KILL L,LGTH,LGHT2,BMCDA,BMCDA2,BMCCOM,FLG,BEGDT,CT
+22 DO BMES^XPDUTL("Completed clean up RCIS Comments file . . .")
+23 QUIT
+24 ;
P12 ;Add Report Opt and Call-in options
+1 ;S BMC="BMC*4.0*12" Q:$$INSTALLD^BMC4P0(BMC)
+2 DO BMES^XPDUTL("Begin adding option for CHS Paid Report.")
+3 IF $$ADD^XPDMENU("BMC MENU-RPTS ADMINISTRATIVE","BMC RPT-CHS ONLY PAID","CHSP")
DO MES^XPDUTL($JUSTIFY("",5)_"Report for CHS Paid Referrals option added to Adm Report option")
+4 DO BMES^XPDUTL("Begin adding Edit option for Call-in Referrals.")
+5 IF $$ADD^XPDMENU("BMC MENU REFERRAL MANAGEMENT","BMC CALL-IN REFERRAL EDIT","CIN")
DO MES^XPDUTL($JUSTIFY("",5)_"Edit Call in Referrals added to Referral Management Menu.")
+6 DO MES^XPDUTL("END updating option.")
VREF ;CLEAN UP V REF FILE
+1 IF $GET(^AUPNVREF(0))
GOTO ZPAR
+2 DO BMES^XPDUTL("Updating V Referral file.")
+3 ;FIX TO STUFF 1202 OF V REFERRAL WITH REQUESTING PROVIDER FROM RCIS REFERRAL ENTRY
+4 ;NULL OUT 1210 FIELD VALUE
+5 ;MOVE AND CORRECT V REFERRAL INFO BASED ON REFERRAL ENTRY
+6 NEW APCDVREF,APCDREF,APCDRP,BMCVDFN,BMCVPRV
+7 SET APCDVREF=0
FOR
SET APCDVREF=$ORDER(^AUPNVREF(APCDVREF))
IF APCDVREF'=+APCDVREF
QUIT
Begin DoDot:1
+8 SET APCDREF=$$VALI^XBDIQ1(9000010.59,APCDVREF,.06)
+9 ;NO REFERRAL IEN
IF APCDREF=""
QUIT
+10 ;no referral??
IF '$DATA(^BMCREF(APCDREF,0))
QUIT
+11 ;REQUESTING PROVIDER IEN
SET APCDRP=$$VALI^XBDIQ1(90001,APCDREF,.06)
+12 SET (BMCVDFN,BMCVPRV)=""
SET BMCVDFN=$$VALI^XBDIQ1(90001,APCDREF,1309)
IF BMCVDFN
SET BMCVPRV=$$PRIMPROV^APCLV(BMCVDFN,"I")
+13 SET DIE="^AUPNVREF("
SET DA=APCDVREF
+14 IF APCDRP
SET DR="1210///@;1202////"_APCDRP
+15 IF 'APCDRP
SET DR="1210///@;1202///@"
+16 ;SET PROV ENCOUNTER
IF BMCVPRV
SET DR=DR_";1204////"_BMCVPRV
+17 DO ^DIE
+18 IF $DATA(Y)
DO EN^DDIOL("failure to update v referral "_APCDVREF)
+19 KILL DIE,DA,DR
End DoDot:1
+20 DO BMES^XPDUTL("Completed Updating V Referral file.")
ZPAR ;ADD ENTRY TO ZISH PARAMETER FILE
+1 DO BMES^XPDUTL("Adding entry to Zish Send Parameter file.")
+2 SET X="BMC RCIS REPORTS"
SET DIC="^%ZIB(9888888.93,"
SET DIC(0)="L"
+3 DO ^DIC
+4 IF Y<0
WRITE !,"ZISH SEND PARAMETER FOR THE BMC RCIS REPORTS ENTRY COULD NOT BE ADDED, YOU WILL NEED ADD THROUGH FILEMAN"
GOTO GENRET
+5 SET DA=+Y
SET DIE=DIC
+6 SET DR=".07////"_"B"_";.08////"_"sendto"
+7 DO ^DIE
+8 KILL D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM,DA
+9 DO BMES^XPDUTL("Completed adding Entry to Zish Send Parameter file.")
+10 ;
GENRET ;UPDATE GEN RET OPTIONS
+1 DO BMES^XPDUTL("Updating items for the Gen Ret Report option.")
+2 NEW DA,DIE,DIC,DR
+3 SET X="Service Category (CPT)"
SET (DIC,DIE)="^BMCTSORT("
SET DR=".01////Service Cat HCPCS/CPT"
+4 DO ^DIC
IF +Y>0
SET DA=+Y
DO ^DIE
KILL DR
+5 SET X="Util Review Committee"
SET DR=".09////952"
+6 DO ^DIC
IF +Y>0
SET DA=+Y
DO ^DIE
KILL DR
+7 SET X="Mgd Care Committee"
SET DR=".09////950"
+8 DO ^DIC
IF +Y>0
SET DA=+Y
DO ^DIE
KILL DR
+9 SET X="DT Mgd Care Action"
SET DR=".09////951"
+10 DO ^DIC
IF +Y>0
SET DA=+Y
DO ^DIE
KILL DR
+11 SET X="Site Created by"
DO ^DIC
IF +Y<0
SET DIC(0)="L"
Begin DoDot:1
+12 DO ^DIC
SET DA=+Y
+13 SET DR=".02////R;.04////90001.31,.01;.05////S;.06////Site Created by;.07////20;.09////999;.11////R;"
+14 SET DR=DR_"1////S X=$$FACREQ^BMCRLU1(BMCREF);2////S X=$P(^DIC(4,BMCY,0),U)"
+15 DO ^DIE
End DoDot:1
+16 DO BMES^XPDUTL("Completed updating items for the Gen Ret option . . .")
+17 KILL DA,DIE,DIC,DR
+18 QUIT
