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

ACHS31P6.m

Go to the documentation of this file. 
  1. ACHS31P6 ;IHS/SET/FCJ - ACHS 3.1 PATCH 6 ;  [ 03/24/2005  8:34 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**6**;JUN 11, 2001
  1.  ;
  1.  ; IHS/SET/FCJ ACHS*3.1*6 4.29.03 ;ORIGINAL ROUTINE FROM GTH MODIFIED
  1.  ; FOR PATCH 6
  1.  ; IHS/SET/JVK ACHS*3.1*6 6.20.03 ;ADDED SET OF REVERSE STATUS ON DENIAL
  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)_" Patch "_$P($T(+2),";",5)_".",IOM)
  1.  ;
  1.  NEW IORVON,IORVOFF
  1.  S X="IORVON;IORVOFF"
  1.  D ENDR^%ZISS
  1.  ;
  1.  I $$VCHK("ACHS","3.1",2,"'=")
  1.  ;
  1.  NEW DA,DIC
  1.  S X="ACHS",DIC="^DIC(9.4,",DIC(0)="",D="C"
  1.  D IX^DIC
  1.  I Y<0,$D(^DIC(9.4,"C","ACHS")) D
  1.  . W !!,*7,*7,$$CJ^XLFSTR("You Have More Than One Entry In The",IOM),!,$$CJ^XLFSTR("PACKAGE File with an ""ACHS"" prefix.",IOM)
  1.  . W !,$$CJ^XLFSTR(IORVON_"One entry needs to be deleted."_IORVOFF,IOM)
  1.  . D SORRY(2)
  1.  .Q
  1.  ;
  1.  I $G(XPDQUIT) W !,$$CJ^XLFSTR(IORVON_"FIX IT! Before Proceeding."_IORVOFF,IOM),!!,*7,*7,*7 Q
  1.  ;
  1.  W !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
  1.  ;
  1.  D HELP^XBHELP("INTROE","ACHS31P6")
  1.  I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2) Q
  1.  ;
  1.  I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0 D HELP^XBHELP("INTROI","ACHS31P6") I '$$DIR^XBDIR("E","","","","","",1) D SORRY(2)
  1.  ;
  1.  Q
  1.  ;
  1. SORRY(X) ;
  1.  KILL DIFQ
  1.  S XPDQUIT=X
  1.  W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
  1.  Q
  1.  ;
  1. VCHK(ACHSPRE,ACHSVER,ACHSQUIT,ACHSCOMP) ; Check versions needed.
  1.  ;  
  1.  NEW ACHSV
  1.  S ACHSV=$$VERSION^XPDUTL(ACHSPRE)
  1.  W !,$$CJ^XLFSTR("Need "_$S(ACHSCOMP="<":"at least ",1:"")_ACHSPRE_" v "_ACHSVER_"....."_ACHSPRE_" v "_ACHSV_" Present",IOM)
  1.  I @(ACHSV_ACHSCOMP_ACHSVER) D SORRY(ACHSQUIT) Q 0
  1.  Q 1
  1.  ;
  1. PRE ;EP - From KIDS.
  1.  I $$NEWCP^XPDUTL("PRE1","AUDS^ACHS31P6")
  1.  Q
  1.  ;
  1. POST ;EP - From KIDS.
  1.  ;
  1.  ; ---Patches 3,4 & 5 Checks for installs are done in Install Questions.
  1.  ; ---Patch question for 3 was removed, need "C" index for lookup
  1.  ; ---of non-registered patients.
  1.  S %="P4^ACHS31P6"
  1.  I $$NEWCP^XPDUTL("POS4-"_%,%)
  1.  S %="P5^ACHS31P6"
  1.  I $$NEWCP^XPDUTL("POS5-"_%,%)
  1.  ;
  1.  ; --- Atch Denial APPEAL option.
  1.  S %="P6OPT^ACHS31P6"
  1.  I $$NEWCP^XPDUTL("POS9-"_%,%)
  1.  ;
  1.  ; --- Re-index non-registered patient name.
  1.  S %="NONREG^ACHS31P6"
  1.  I $$NEWCP^XPDUTL("POS10-"_%,%)
  1.  ;
  1.  ; --- Set appeal status if denial reversed.
  1.  S %="DENREV^ACHS31P6"
  1.  I $$NEWCP^XPDUTL("POS11-"_%,%)
  1.  ;
  1.  ; --- Restore dd audit settings.
  1.  S %="AUDR^ACHS31P6"
  1.  I $$NEWCP^XPDUTL("POS12-"_%,%)
  1.  ;
  1.  ; --- Send mail message of install.
  1.  S %="MAIL^ACHS31P6"
  1.  I $$NEWCP^XPDUTL("POS13-"_%,%)
  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("ACHS31P6",$J)
  1.  D RSLT(" --- ACHS v 3.1 Patch 5, 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(""ACHS31P6"",$J,",XMY(1)="",XMY(DUZ)=""
  1.  F %="ACHSZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
  1.  D ^XMD
  1.  KILL ^TMP("ACHS31P6",$J)
  1.  D MES^XPDUTL("END Delivering MailMan message to select users.")
  1.  Q
  1.  ;
  1. RSLT(%) S ^(0)=$G(^TMP("ACHS31P6",$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) Display cancel and reversed number on HQ1 Denial report.
  1.  ;;(2) Added new options for Denial Appeals: Appeal Status Edit,
  1.  ;;    Cancel Denial Document, and Denial Status Edit. 
  1.  ;;(3) Added new option, Send Approval message to FI, flag for
  1.  ;;    Sterilization form completed, data will be sent to FI.
  1.  ;;(4) Added ability to add Denial Comments placed in CHS office notes.
  1.  ;;(5) Close Device on print of Denials by Alpha Report.
  1.  ;;(6) Print "X" in box 17 of 843.
  1.  ;;(7) Added Date of Service on Denial Documents by Issue date Report.
  1.  ;;(8) EOBR Issues Fixed:
  1.  ;;    a. Refunds with zero pay, third party pays in full not adjusting
  1.  ;;    b. Not allowing negative payment adjustments for third party
  1.  ;;    c. SU print out does not match the print for FI paid amount
  1.  ;;    d. Delete previous eobr files caused undef on Windows server
  1.  ;;(9) Fixed Deferred Service letter format problem.
  1.  ;;(10)Object Class Code Report now includes obligated and paid totals.
  1.  ;;(11)Master delivery order report sorts by date of service.
  1.  ;;(12)Denial Statistic's report additional options added to print by 
  1.  ;;    Date of service and option to print by Community.
  1.  ;;(13)Changed SUD/Area Director fields to Non-mandatory in 
  1.  ;;     Denial Facility file.
  1.  ;;(14)Fixed Adjustments to pay, data set wrong in fields.
  1.  ;;(15)DCR Reports not picking up first day of FY
  1.  ;;(16)Denial Lookup on non-registered patients fixed
  1.  ;;(17)Fixed print of Denial letter for selected vendor.
  1.  ;;(18)Print amount paid by vendor and by other resources on letter.
  1.  ;;(19)Examine active CHS jobs before running EOBR.
  1.  ;;(20)Vendor test for required fields will be required in Sept 2003.
  1.  ;;(21)Removed ICD9 request on Dental Denials,now on Medical Denials.
  1.  ;;(22)Vendor Usage report, now prints "*" and total for paid documents.
  1.  ;;(23)Denial letter Office copy, fixed DD, no longer required to print
  1.  ;;(24)Fix of display of 3rd party pay on Display Documents option.
  1.  ;;(25)Option to print Master delivery order by Date issued.
  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.  ;;Standard data dictionaries on your RPMS system have been updated.
  1.  ;;  
  1.  ;;You are receiving this message because of the particular RPMS
  1.  ;;security keys that you hold.  This is for your information, only.
  1.  ;;You need do nothing in response to this message.
  1.  ;;  
  1.  ;;Questions about this patch, which is a product of the RPMS DBA
  1.  ;;,
  1.  ;;can be directed to the Help Desk,
  1.  ;;".
  1.  ;;Please refer to patch "ACHS*3.1*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("ACHS31P6",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^"_$P($P($T(+1),";",2)," ",3,99)
  1.  NEW ACHS
  1.  S ACHS=0
  1.  F  S ACHS=$O(^XTMP("XPDI",XPDA,"FIA",ACHS)) Q:'ACHS  D
  1.  . I '$D(^XTMP("ACHS31P6",ACHS,"DDA")) S ^XTMP("ACHS31P6",ACHS,"DDA")=$G(^DD(ACHS,0,"DDA"))
  1.  . D MES^XPDUTL(" File "_$$RJ^XLFSTR(ACHS,12)_" - "_$$LJ^XLFSTR(^XTMP("XPDI",XPDA,"FIA",ACHS),30)_"- DD audit was '"_$G(^XTMP("ACHS31P6",ACHS,"DDA"))_"'"),MES^XPDUTL($$RJ^XLFSTR("Set to 'Y'",69))
  1.  . S ^DD(ACHS,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 ACHS
  1.  S ACHS=0
  1.  F  S ACHS=$O(^XTMP("ACHS31P6",ACHS)) Q:'ACHS  D
  1.  . S ^DD(ACHS,0,"DDA")=^XTMP("ACHS31P6",ACHS,"DDA")
  1.  . D MES^XPDUTL(" File "_$$RJ^XLFSTR(ACHS,12)_" - "_$$LJ^XLFSTR($$GET1^DID(ACHS,"","","NAME"),30)_"- DD AUDIT Set to '"_^DD(ACHS,0,"DDA")_"'")
  1.  .Q
  1.  KILL ^XTMP("ACHS31P6")
  1.  D MES^XPDUTL("DD AUDIT settings restored.")
  1.  Q
  1.  ; -----------------------------------------------------
  1.  ;
  1. INSTALLD(ACHS) ; Determine if patch ACHS was installed, where ACHS is
  1.  ; the name of the INSTALL.  E.g "AVA*93.2*12".
  1.  ;
  1.  NEW DIC,X,Y
  1.  ;  lookup package.
  1.  S X=$P(ACHS,"*",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(ACHS,"*",2)
  1.  D ^DIC
  1.  I Y<1 Q 0
  1.  ;  lookup patch.
  1.  S DIC=DIC_+Y_",""PAH"",",X=$P(ACHS,"*",3)
  1.  D ^DIC
  1.  Q $S(Y<1:0,1:1)
  1.  ;
  1.  ; -----------------------------------------------------
  1.  ; Fields to be deleted.
  1.  ;File#^FileName^Field#^FieldName
  1. DELFLD ;
  1.  ;;9002069^CHS DATA CONTROL^1^*RESERVED-1
  1.  ;;9002069^CHS DATA CONTROL^3^*BUDGET INDIVIDUAL ACCOU
  1.  ;;9002069.03^PIGGYBACK FACILITIES^.01^PIGGYBACK FACILITIES
  1.  ;;9002069^CHS DATA CONTROL^9^*PIGGYBACK FACILITIES
  1.  ;;9002071.63^* DIAGNOSIS (APC) COMMENT^.01^* DIAGNOSIS (APC) COMMENT
  1.  ;;9002071.06^* DIAGNOSIS (APC)^.01^* DIAGNOSIS (APC)
  1.  ;;9002071.06^* DIAGNOSIS (APC)^2^* DIAGNOSIS (APC) NARRATIVE
  1.  ;;9002071.06^* DIAGNOSIS (APC)^3^* DIAGNOSIS (APC) COMMENT
  1.  ;;9002071.01^DENIAL NUMBER^600^* DIAGNOSIS (APC)
  1.  ;;9002080^CHS FACILITY^14.1^*PROCESS PAT FOR AREA NC
  1.  ;;9002080^CHS FACILITY^14.13^*PROCESS DOCUMENT RECS F
  1.  ;;9002080.01^DOCUMENT^13.66^* VEND AGR NUMB (NOT USE
  1.  ;;9002080.01^DOCUMENT^77^*DENTAL SERVICES
  1.  ;;END
  1.  ; Note:  above line is a loop ender.
  1.  D BMES^XPDUTL("BEGIN Removing deleted fields from CHS data dictionaries.")
  1.  NEW DA,DIK
  1.  F ACHS=1:1 S X=$P($T(DELFLD+ACHS),";",3) Q:X="END"  D
  1.  . D MES^XPDUTL($J("",5)_"Deleting '"_$$LJ^XLFSTR($P(X,U,4),30,".")_"' from '"_$P(X,U,2)_"'")
  1.  . S DIK="^DD("_$P(X,U,1)_",",DA(1)=$P(X,U,1),DA=$P(X,U,3)
  1.  . D ^DIK
  1.  . Q
  1.  . ; KILL ^DD(9999999.3911) ; 4 of the 0th nodes aren't KILL'd by ^DIK.
  1.  .Q
  1.  D MES^XPDUTL("END Removing deleted fields from CHS data dictionaries.")
  1.  Q
  1.  ;
  1. DENOPT ; check for 638 facility, and add options if 638
  1.  D BMES^XPDUTL("BEGIN Checking for 638 facility.")
  1.  NEW ACHS
  1.  S ACHS=0
  1.  F  S ACHS=$O(^ACHSF(ACHS)) Q:'ACHS   I $P(^ACHSF(ACHS,0),U,8)="Y" D  Q
  1.  . I $$ADD^XPDMENU("ACHS DEFDEN MENU PARM","ACHSDENPARM","P638") D MES^XPDUTL($J("",5)_"Denial parameter menu option added for 638 facility")
  1.  . I $$ADD^XPDMENU("ACHSDENPARM","ACHSDENPARMREA","AREA") D MES^XPDUTL($J("",5)_"Denial parameter menu option added for 638 facility")
  1.  .Q
  1.  D MES^XPDUTL("END Checking for 638 facility.")
  1.  Q
  1.  ;
  1. M278 ;
  1.  D BMES^XPDUTL("BEGIN Attaching 278 menu.")
  1.  I $$ADD^XPDMENU("ACHSAA","ACHS 278 MENU","278") D MES^XPDUTL($J("",5)_"278 Menu added to Document Generation menu."),MES^XPDUTL($J("",5)_"Note that the security lock was *NOT* allocated.") I 1
  1.  E  D MES^XPDUTL($J("",5)_"ERROR:   278 menu attachment FAILED.")
  1.  D MES^XPDUTL("END Attaching 278 menu.")
  1.  Q
  1.  ;
  1. NONREG ;EP - from KIDS.
  1.  D BMES^XPDUTL("BEGIN Re-index of Patient Name in Denials.")
  1.  NEW ACHS,DA,DIK
  1.  S ACHS=0
  1.  F  S ACHS=$O(^ACHSDEN(ACHS)) Q:'ACHS  D
  1.  . KILL ^ACHSDEN(ACHS,"D","C"),^ACHSDEN(ACHS,"D","N")
  1.  . S DIK="^ACHSDEN("_ACHS_",""D"""_",",DA(1)=ACHS
  1.  . F DIK(1)="7^C","10^C" D ENALL^DIK
  1.  .Q
  1.  D MES^XPDUTL("END Re-index of Patient Name in Denials.")
  1.  Q
  1. DENREV ;EP - From KIDS.  
  1.  ;SETS DENIAL STATUS IF DENIAL WAS REVERSED
  1.  NEW ACHS
  1.  S ACHSASTA=0,ACHSDA=0,ACHS=0
  1.  S ACHSASTA=$O(^ACHSDENA("B","REVERSED AFTER APPEAL",ACHSASTA))
  1.  F  S ACHS=$O(^ACHSDEN(ACHS)) Q:ACHS'?1N.N  D
  1.  . S ACHSDA=0
  1.  .F  S ACHSDA=$O(^ACHSDEN(ACHS,"D",ACHSDA)) Q:ACHSDA'?1N.N  D
  1.  .. S ACHSDSTA=$P(^ACHSDEN(ACHS,"D",ACHSDA,0),U,8)
  1.  .. Q:'$D(^ACHSDEN(ACHS,"D",ACHSDA,400,0))
  1.  .. I ACHSDSTA["R" S $P(^ACHSDEN(ACHS,"D",ACHSDA,400,0),U,3)=ACHSASTA
  1.  K ACHSASTA,ACHSDA
  1.  Q
  1.  ;
  1. P6OPT ;EP - FROM KIDS.
  1.  ;ADD NEW OPTIONS FOR PATCH 6, DENIAL APPEAL,EDITS AND CANCEL, FI FIELD
  1.  D BMES^XPDUTL("Begin adding new options.")
  1.  I $$ADD^XPDMENU("ACHSAA","ACHSFIM","FIM") D MES^XPDUTL($J("",5)_"Send approval Message to FI added to Document Generation Menu")
  1.  I $$ADD^XPDMENU("ACHS DEFDEN MENU","ACHS DEN APPEAL MENU","APP") D MES^XPDUTL($J("",5)_"Denial Appeal menu option added to CHS Denial/Deferred ServciesMenu")
  1.  D MES^XPDUTL("END updating options.")
  1.  Q
  1.  ;
  1. P4 ;EP - from KIDS.
  1.  Q:'$G(XPDQUES("POS4"))
  1.  D BMES^XPDUTL("BEGIN Re-index of Patient Name in Deferred Services.")
  1.  NEW ACHS,DA,DIK
  1.  S ACHS=0
  1.  F  S ACHS=$O(^ACHSDEF(ACHS)) Q:'ACHS  D
  1.  . KILL ^ACHSDEF(ACHS,"D","C"),^ACHSDEF(ACHS,"D","N")
  1.  . S DIK="^ACHSDEF("_ACHS_",""D"""_",",DA(1)=ACHS
  1.  . F DIK(1)="6^C","7^N" D ENALL^DIK
  1.  .Q
  1.  D MES^XPDUTL("END Re-index of Patient Name in Deferred Services.")
  1.  Q
  1.  ;
  1. P5 ;EP - from KIDS
  1.  Q:'$G(XPDQUES("POS5"))
  1.  ;
  1.  ; --- Atch Denial ltr edit option at 638 sites.
  1.  S %="DENOPT^ACHS31P6"
  1.  I $$NEWCP^XPDUTL("POS5-"_%,%)
  1.  ;
  1.  ; --- Delete fiels in CHS files marked for deletion.
  1.  S %="DELFLD^ACHS31P6"
  1.  I $$NEWCP^XPDUTL("POS6-"_%,%)
  1.  ;
  1.  ; --- Atch 278 menu to Doc edit option.
  1.  S %="M278^ACHS31P6"
  1.  I $$NEWCP^XPDUTL("POS7-"_%,%)
  1.  ;
  1.  ; --- Remove non-standard option auditing from CHS options. 
  1.  S %="POS^ACHS31P0"
  1.  I $$NEWCP^XPDUTL("POS8-"_%,%)
  1.  Q