- BMC4P11 ;IHS/OIT/FCJ - BMC 4.0 PATCH 11 ; 16 Feb 2011 2:54 PM
- ;;4.0;REFERRED CARE INFO SYSTEM;**11**;JAN 09, 2006;Build 51
- ;ORIGINAL ROUTINE FR BMC4P9
- ;
- 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^BMC4P11("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","BMC4P11")
- I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2) Q
- I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0 D HELP^XBHELP("INTROI","BMC4P11") 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^BMC4P11")
- ; 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^BMC4P11"
- I $$NEWCP^XPDUTL("POS1-"_%,%)
- ;
- ; --- Set new Index "BA" and "BB"
- S %="INDX^BMC4P11"
- I $$NEWCP^XPDUTL("POS2-"_%,%)
- ;
- ; --- Add Provider/Vendor Option
- S %="P5^BMC4P11"
- I $$NEWCP^XPDUTL("POS3-"_%,%)
- ;
- ; --- Add MED HX Option and fx CHS 2010 PO #'s
- S %="P6^BMC4P11"
- I $$NEWCP^XPDUTL("POS4-"_%,%)
- ;
- ; --- Add Report Option for printing C32s for Active referrals
- S %="P7^BMC4P11"
- I $$NEWCP^XPDUTL("POS5-"_%,%)
- ;
- ; --- Add Report Option for TOC and Edit option for TOC
- S %="P8^BMC4P11"
- I $$NEWCP^XPDUTL("POS6-"_%,%)
- ;
- ; ---Re-Add Report Options, removed because a parent opt sent
- S %="P9^BMC4P11"
- I $$NEWCP^XPDUTL("POS8-"_%,%)
- ;
- ; ---Remove CHS PAID option from GEN Ref selection list
- S %="P10^BMC4P11"
- I $$NEWCP^XPDUTL("POS9-"_%,%)
- ;
- ; ---Remove clinic field from V ref file
- S %="P10VR^BMC4P11"
- I $$NEWCP^XPDUTL("POS10-"_%,%)
- ;
- ; ---Reformat comments to 80 char lenght in RCIS Comments file
- S %="P10COM^BMC4P11"
- I $$NEWCP^XPDUTL("POS11-"_%,%)
- ;
- ; --- Send mail message of install.
- S %="MAIL^BMC4P11"
- I $$NEWCP^XPDUTL("POS12-"_%,%)
- ;
- Q
- ;
- MAIL ;
- D BMES^XPDUTL("BEGIN Delivering MailMan message to select users.")
- NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
- KILL ^TMP("BMC4P11",$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(""BMC4P11"",$J,",XMY(1)="",XMY(DUZ)=""
- F %="BMCZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
- D ^XMD
- KILL ^TMP("BMC4P11",$J)
- D MES^XPDUTL("END Delivering MailMan message to select users.")
- Q
- ;
- RSLT(%) S ^(0)=$G(^TMP("BMC4P11",$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:
- ;;
- ;; Changes include
- ;; 1. Modify RCIS CPT CATEGORY file to include HCPCS
- ;; 2. Modify screens for adding/editing for HCPCS update
- ;; 3. Rebuild special reports menu option
- ;; 4. Fix for allowing date/time entry on add referral
- ;; 5. Fix for truncation of Med Hx Comment from GUI
- ;; 6. Change label on GUI for CPT Category to include HCPCS
- ;;
- ;;###
- ;
- 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 applications
- ;;can be directed to the OIT Support Center, at 505-248-4371,
- ;;or via e-mail to support@ihs.gov.
- ;;Please refer to patch "bmc*4.0*11".
- ;;
- ;;###;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("BMC4P11",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("BMC4P11",BMC,"DDA")) S ^XTMP("BMC4P11",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("BMC4P11",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("BMC4P11",BMC)) Q:'BMC D
- . S ^DD(BMC,0,"DDA")=^XTMP("BMC4P11",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("BMC4P11")
- 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" 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 menu options
- 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 DA=192,DIE="^BMCTSORT(",DR=".01////"_"@"
- 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
- ; ------------------------------------------------------
- BMC4P11 ;IHS/OIT/FCJ - BMC 4.0 PATCH 11 ; 16 Feb 2011 2:54 PM
- +1 ;;4.0;REFERRED CARE INFO SYSTEM;**11**;JAN 09, 2006;Build 51
- +2 ;ORIGINAL ROUTINE FR BMC4P9
- +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^BMC4P11("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","BMC4P11")
- +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","BMC4P11")
- 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^BMC4P11")
- +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^BMC4P11"
- +3 IF $$NEWCP^XPDUTL("POS1-"_%,%)
- +4 ;
- +5 ; --- Set new Index "BA" and "BB"
- +6 SET %="INDX^BMC4P11"
- +7 IF $$NEWCP^XPDUTL("POS2-"_%,%)
- +8 ;
- +9 ; --- Add Provider/Vendor Option
- +10 SET %="P5^BMC4P11"
- +11 IF $$NEWCP^XPDUTL("POS3-"_%,%)
- +12 ;
- +13 ; --- Add MED HX Option and fx CHS 2010 PO #'s
- +14 SET %="P6^BMC4P11"
- +15 IF $$NEWCP^XPDUTL("POS4-"_%,%)
- +16 ;
- +17 ; --- Add Report Option for printing C32s for Active referrals
- +18 SET %="P7^BMC4P11"
- +19 IF $$NEWCP^XPDUTL("POS5-"_%,%)
- +20 ;
- +21 ; --- Add Report Option for TOC and Edit option for TOC
- +22 SET %="P8^BMC4P11"
- +23 IF $$NEWCP^XPDUTL("POS6-"_%,%)
- +24 ;
- +25 ; ---Re-Add Report Options, removed because a parent opt sent
- +26 SET %="P9^BMC4P11"
- +27 IF $$NEWCP^XPDUTL("POS8-"_%,%)
- +28 ;
- +29 ; ---Remove CHS PAID option from GEN Ref selection list
- +30 SET %="P10^BMC4P11"
- +31 IF $$NEWCP^XPDUTL("POS9-"_%,%)
- +32 ;
- +33 ; ---Remove clinic field from V ref file
- +34 SET %="P10VR^BMC4P11"
- +35 IF $$NEWCP^XPDUTL("POS10-"_%,%)
- +36 ;
- +37 ; ---Reformat comments to 80 char lenght in RCIS Comments file
- +38 SET %="P10COM^BMC4P11"
- +39 IF $$NEWCP^XPDUTL("POS11-"_%,%)
- +40 ;
- +41 ; --- Send mail message of install.
- +42 SET %="MAIL^BMC4P11"
- +43 IF $$NEWCP^XPDUTL("POS12-"_%,%)
- +44 ;
- +45 QUIT
- +46 ;
- MAIL ;
- +1 DO BMES^XPDUTL("BEGIN Delivering MailMan message to select users.")
- +2 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
- +3 KILL ^TMP("BMC4P11",$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(""BMC4P11"",$J,"
- SET XMY(1)=""
- SET XMY(DUZ)=""
- +9 FOR %="BMCZMENU","XUMGR","XUPROG","XUPROGMODE"
- DO SINGLE(%)
- +10 DO ^XMD
- +11 KILL ^TMP("BMC4P11",$JOB)
- +12 DO MES^XPDUTL("END Delivering MailMan message to select users.")
- +13 QUIT
- +14 ;
- RSLT(%) SET ^(0)=$GET(^TMP("BMC4P11",$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 ;; Changes include
- +4 ;; 1. Modify RCIS CPT CATEGORY file to include HCPCS
- +5 ;; 2. Modify screens for adding/editing for HCPCS update
- +6 ;; 3. Rebuild special reports menu option
- +7 ;; 4. Fix for allowing date/time entry on add referral
- +8 ;; 5. Fix for truncation of Med Hx Comment from GUI
- +9 ;; 6. Change label on GUI for CPT Category to include HCPCS
- +10 ;;
- +11 ;;###
- +12 ;
- 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 applications
- +11 ;;can be directed to the OIT Support Center, at 505-248-4371,
- +12 ;;or via e-mail to support@ihs.gov.
- +13 ;;Please refer to patch "bmc*4.0*11".
- +14 ;;
- +15 ;;###;NOTE: This line indicates the end of text in this message.
- +16 ;
- +17 ; -----------------------------------------------------
- +18 ; The global location for dictionary audit is:
- +19 ; ^DD(FILE,0,"DDA")
- +20 ; If the valuey is "Y", dd audit is on. Any other value, or the
- +21 ; absence of the node, means dd audit is off.
- +22 ; -----------------------------------------------------
- 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("BMC4P11",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("BMC4P11",BMC,"DDA"))
- SET ^XTMP("BMC4P11",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("BMC4P11",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("BMC4P11",BMC))
- IF 'BMC
- QUIT
- Begin DoDot:1
- +5 SET ^DD(BMC,0,"DDA")=^XTMP("BMC4P11",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("BMC4P11")
- +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"
- 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
- +14 ; ------------------------------------------------------
- P9 ;Add Report menu options
- +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
- +9 ; ------------------------------------------------------
- P10 ;Patch 10
- +1 SET BMC="BMC*4.0*10"
- IF $$INSTALLD^BMC4P0(BMC)
- QUIT
- +2 ;Delete GEN RET option 99.1 CHS Paid To Date
- +3 NEW DA,DIE,DIC,DR
- +4 SET DA=192
- SET DIE="^BMCTSORT("
- SET DR=".01////"_"@"
- +5 DO ^DIE
- +6 DO BMES^XPDUTL("CHS Paid To Date removed from Gen Ret items . . .")
- +7 QUIT
- +8 ;
- 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 ; ------------------------------------------------------