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

ACHS3115.m

Go to the documentation of this file. 
  1. ACHS3115 ;IHS/OIT/FCJ - ACHS 3.1 PATCH 14 ; JUL 10, 2008
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**15**;JUNE 11,2001
  1.  ;3.1*15 12/7/2006;IHS/OIT/FCJ - ORIG RTN P14
  1.  ;               MOVED ENV CHECK TO ACHS31E1
  1.  ;
  1. PRE ;EP - From KIDS.
  1.  I $$NEWCP^XPDUTL("PRE1","AUDS^ACHS3115")
  1.  Q
  1.  ;
  1. POST ;EP - From KIDS.
  1.  ; ---Patches 4,5,6,7 Checks installs are done in Install Questions.
  1.  ; ---Question for 3 was removed, need "C" index for lookup of non-registered patients.
  1.  S %="P4^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS4-"_%,%)
  1.  S %="P5^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS5-"_%,%)
  1.  ;
  1.  S %="P6^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS9-"_%,%)
  1.  ;
  1.  S %="P7^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS12-"_%,%)
  1.  ;
  1.  ;PATCH 12
  1.  S %="P12^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS14-"_%,%)
  1.  ;       
  1.  ;PATCH 13
  1.  S %="P13^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS17-"_%,%)
  1.  ;
  1.  ;PATCH 14
  1.  S %="P14^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS18-"_%,%)
  1.  ;
  1.  ;PATCH 15
  1.  S %="P15^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS19-"_%,%)
  1.  ; --- Restore dd audit settings.
  1.  S %="AUDR^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS20-"_%,%)
  1.  ;
  1.  ; --- Send mail message of install.
  1.  S %="MAIL^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS21-"_%,%)
  1.  ;
  1.  Q
  1. MAIL ;
  1.  D BMES^XPDUTL("BEGIN Delivering MailMan message to select users.")
  1.  NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
  1.  KILL ^TMP("ACHS3115",$J)
  1.  D RSLT(" --- ACHS v 3.1 Patch 15, has been installed into this namespace ---")
  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(""ACHS3115"",$J,",XMY(1)="",XMY(DUZ)=""
  1.  F %="ACHSZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
  1.  D ^XMD
  1.  KILL ^TMP("ACHS3115",$J)
  1.  D MES^XPDUTL("END Delivering MailMan message to select users.")
  1.  Q
  1.  ;
  1. RSLT(%) S ^(0)=$G(^TMP("ACHS3115",$J,0))+1,^(^(0))=%
  1.  Q
  1.  ;
  1. SINGLE(K) ; Get holders of a key
  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. GREET ;;To add to mail message.
  1.  ;;  
  1.  ;;Standard data dictionaries on your RPMS system have been updated.
  1.  ;;  
  1.  ;;You are receiving this message because of the RPMS
  1.  ;;security keys that you hold.  This is for your information.
  1.  ;;Do not respond to this message.
  1.  ;;  
  1.  ;;Questions about this patch may be directed to
  1.  ;;the Help Desk,
  1.  ;;refer to patch "ACHS*3.1*15".
  1.  ;;  
  1.  ;;###;NOTE: This line end of text.
  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("ACHS3115",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("ACHS3115",ACHS,"DDA")) S ^XTMP("ACHS3115",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("ACHS3115",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("ACHS3115",ACHS)) Q:'ACHS  D
  1.  . S ^DD(ACHS,0,"DDA")=^XTMP("ACHS3115",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("ACHS3115")
  1.  D MES^XPDUTL("DD AUDIT settings restored.")
  1.  Q
  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.  ; 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.  .; KILL ^DD(9999999.3911) ; 4 of the 0th nodes aren't KILL'd by ^DIK.
  1.  D MES^XPDUTL("END Removing deleted fields from CHS data dictionaries.")
  1.  Q
  1.  ;
  1. DENOPT ;638 facility then add options
  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.  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. P6OPT ;EP - FR KIDS
  1.  ;ADD NEW OPTIONS - 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. NONREG ;EP - fr 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.  .K ^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.  D MES^XPDUTL("END Re-index of Patient Name in Denials.")
  1.  Q
  1. DENREV ;EP - Fr 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. V145DD ;EP - FR KIDS
  1.  ;Removes V 1.45 DD'S LEFT BEHIND
  1.  K ^UTILITY("XBDSET",$J)
  1.  F XBBPI=1:1 S XBBPIX=$P($T(LIST+XBBPI),";;",2) Q:XBBPIX="END"  S XBBPIY=$P(XBBPIX,"=",2,99),XBBPIX=$P(XBBPIX,"=",1) S @XBBPIX=XBBPIY
  1.  K XBBPI,XBBPIX,XBBPIY D EN2^XBKD
  1.  Q
  1. LIST ;
  1.  ;;^UTILITY("XBDSET",$J,1803100)=S^S
  1.  ;;^UTILITY("XBDSET",$J,1803101)=S^S
  1.  ;;^UTILITY("XBDSET",$J,1803102)=S^S
  1.  ;;^UTILITY("XBDSET",$J,1803103)=S^S
  1.  ;;^UTILITY("XBDSET",$J,1803104)=S^S
  1.  ;;^UTILITY("XBDSET",$J,1803107)=S^S
  1.  ;;^UTILITY("XBDSET",$J,1803109)=S^S
  1.  ;;^UTILITY("XBDSET",$J,1803110)=S^S
  1.  ;;^UTILITY("XBDSET",$J,1803111)=S^S
  1.  ;;^UTILITY("XBDSET",$J,1803112)=S^S
  1.  ;;^UTILITY("XBDSET",$J,1803113)=S^S
  1.  ;;^UTILITY("XBDSET",$J,1803115)=S^S
  1.  ;;^UTILITY("XBDSET",$J,1803115)=S^S
  1.  ;;END
  1.  ;Above line ends loop
  1.  ;
  1. P7OPT ;EP -FR KIDS
  1.  ;ADD NEW OPTIONS FOR P 7, ELECTRONIC SIG AND REPORTS
  1.  D BMES^XPDUTL("Adding new options.")
  1.  I $$ADD^XPDMENU("ACHSMENU","ACHS E-SIG MENU","EMNU") D MES^XPDUTL($J("",5)_"Electronic Signature Authorization Menu to main CHS Menu")
  1.  I $$ADD^XPDMENU("ACHS E-SIG MENU","ACHS E-SIG AUTHORIZING OFC.","SIGA")
  1.  I $$ADD^XPDMENU("ACHS E-SIG MENU","ACHS E-SIG ORDERING OFC.","SIGO") D MES^XPDUTL($J("",5)_"Electronic Signature for Authorizing Official, Electronic Signature for Ordering Official")
  1.  I $$ADD^XPDMENU("ACHSREPORTS","ACHS E-SIG REPORTS","ERPT")
  1.  I $$ADD^XPDMENU("ACHS E-SIG REPORTS","ACHS E-SIG APPROVED REPORT","ESAP")
  1.  I $$ADD^XPDMENU("ACHS E-SIG REPORTS","ACHS E-SIG PENDING SIG REPORT","ESPD")
  1.  D MES^XPDUTL($J("",5)_"Options in E-Signature Reports added")
  1.  I $$ADD^XPDMENU("ACHSMGPAR","ACHS E-SIG ADD EDIT USERS","EOFF")
  1.  I $$ADD^XPDMENU("ACHSMGPAR","ACHS E-SIG SITE PARAMETER","ESIT") D MES^XPDUTL($J("",5)_"Option for adding Authorized E-Signature users and E-Site Paramaters added to facility management options")
  1.  I $$ADD^XPDMENU("ACHSMGR","ACHSMGPAR") D MES^XPDUTL($J("",5)_"Attach E-Sig to facility Management")
  1.  D MES^XPDUTL("Key for E-Sig Menu is ACHSZESIG,for Adding authorized users is ACHSZPARM.")
  1.  D MES^XPDUTL("END updating options.")
  1.  Q
  1.  ;
  1. HHS ;
  1.  D BMES^XPDUTL("BEGIN Checking for IHS facility.")
  1.  N ACHSI
  1.  S ACHSI=0
  1.  F  S ACHSI=$O(^ACHSF(ACHSI)) Q:ACHSI'?1N.N  I $P(^ACHSF(ACHSI,0),U,8)'="Y" D  Q
  1.  .I $$ADD^XPDMENU("ACHSMGR","ACHSHHS","HHS") D MES^XPDUTL($J("",5)_"HHS Contract Action Type edit added for IHS facilities")
  1.  D MES^XPDUTL("END Checking for IHS facilities.")
  1.  Q
  1. UFMS ;EP-fr KIDS P 13
  1.  ;ADD UFMS START DATE TO CHS FAC FILE
  1.  S X=0 F  S X=$O(^ACHSF("B",X)) Q:X'?1N.N  D
  1.  .S X1=0 F  S X1=$O(^ACHSF("B",X,X1)) Q:X1'?1N.N  D
  1.  ..S:$P(^ACHSF(X1,0),U,8)="N" $P(^ACHSF(X1,0),U,13)=3071001
  1.  ;ADD IE SERVER TO ZISH SEND PAR
  1.  S X="ACHS UFMS B",DIC="^%ZIB(9888888.93,",DIC(0)="L"
  1.  D ^DIC
  1.  I Y<0 W !,"ZISH SEND PARAMETER FOR THE ACHS UFMS ENTRY COULD NOT BE ADDED, YOU WILL NEED TO THROUGH FILEMAN" Q
  1.  S DA=+Y,DIE=DIC
  1.  S DR=".02////"_"quovadx-ie.DOMAIN.NAME"_";.03////"_"ufmsuser"_";.04////"_"vjrsshn9"_";.06////"_"-iau"_";.07////"_"B"_";.08////"_"sendto"
  1.  D ^DIE
  1.  K D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM,DA
  1.  Q
  1. DCIS ;EP-FR kids P14
  1.  N X,Y
  1.  S ACHSUNM="",ACHSUNM=$S($$OS^ACHS=1:"D1/WEBFRS_CHS",1:"D1\WEBFRS_CHS")
  1.  S X="ACHS WEBFRS B",DIC="^%ZIB(9888888.93,",DIC(0)="L"
  1.  D ^DIC
  1.  I Y<0 W !,"ZISH SEND PARAMETER FOR THE ACHS WEBFRS ENTRY COULD NOT BE ADDED, YOU WILL NEED TO EDIT USING FILEMAN" Q
  1.  S DA=+Y,DIE=DIC
  1.  S DR=".02////"_"INTRANETFTP.DOMAIN.NAME"_";.03////"_ACHSUNM_";.04////"_"oFRkd9UXaIIob0e"_";.06////"_"-iaun"_";.07////"_"B"_";.08////"_"sendto"
  1.  D ^DIE
  1.  K D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM,DA,ACHSUNM
  1. SSC ;ADD NAICS CODES TO SSC P14
  1.  S ACHSFAC=""
  1.  F  S ACHSFAC=$O(^ACHS(3,"B",ACHSFAC)) Q:ACHSFAC'?1N.N  D
  1.  .S ACHSSSC="" F  S ACHSSSC=$O(^ACHS(3,ACHSFAC,1,"B",ACHSSSC)) Q:ACHSSSC=""  D
  1.  ..S X=""
  1.  ..I (ACHSSSC=2185)!(ACHSSSC=4319) S X=621999
  1.  ..I (ACHSSSC="252A")!(ACHSSSC="252B") S X=621511
  1.  ..I (ACHSSSC="252D") S X=339116
  1.  ..I (ACHSSSC="252G")!(ACHSSSC="252L")!(ACHSSSC="252Q") S X=622110
  1.  ..I (ACHSSSC="252M") S X=623110
  1.  ..I (ACHSSSC="252S") S X=621340
  1.  ..I (ACHSSSC="252H")!(ACHSSSC="252J") S X=621512
  1.  ..I (ACHSSSC="254A")!(ACHSSSC="254B")!(ACHSSSC="254C")!(ACHSSSC="254D") S X=621111
  1.  ..I (ACHSSSC="254E") S X=621210
  1.  ..I (ACHSSSC="254G")!(ACHSSSC="254J") S X=622310
  1.  ..I (ACHSSSC="254L")!(ACHSSSC="263K") S X=621320
  1.  ..I (ACHSSSC="253A")!(ACHSSSC="253G") S X=621999
  1.  ..I (ACHSSSC="263L") S X=621340
  1.  ..Q:X=""
  1.  ..S DIC="^ACHS(3.1," D ^DIC
  1.  ..S X="" S X=$O(^ACHS(3,ACHSFAC,1,"B",ACHSSSC,X))
  1.  ..S $P(^ACHS(3,ACHSFAC,1,X,0),U,6)=$P(Y,U)
  1.  Q
  1. ZISHOS ;EP-P 15 IF OS=UNIX UPDATE PARAMTER TO NOT SEND ZIPPED FILE
  1.  I $$OS^ACHS=1 D
  1.  .S X="ACHS WEBFRS B",(DIE,DIC)="^%ZIB(9888888.93,"
  1.  .D ^DIC
  1.  .I Y<0 W !,"ACHS WEBFRS B ZISH PARAMETER ENTRY NOT FOUND, FEDERAL SITES-ENTRY IS REQUIRED." Q
  1.  .S DA=+Y,DR=".06////"_"-iaun" D ^DIE
  1.  .K D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM,Y,X
  1. DRPT ;ADD DCIS ERROR REPORT OPT P15
  1.  I $$ADD^XPDMENU("ACHSREPORTS","ACHSRPTDCISERROR","DCIS") D MES^XPDUTL($J("",5)_"DCIS Error Report Option added to the Report Menu")
  1.  Q
  1. P4 ;EP - fr 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.  .K ^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.  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.  ; ---Denial ltr edit option at 638 sites
  1.  S %="DENOPT^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS5-"_%,%)
  1.  ; ---Delete fields in CHS files marked for deletion
  1.  S %="DELFLD^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS6-"_%,%)
  1.  ; --- 278 menu option
  1.  S %="M278^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS7-"_%,%)
  1.  ; ---Remove non-standard option auditing from CHS 
  1.  S %="POS^ACHS31P0"
  1.  I $$NEWCP^XPDUTL("POS8-"_%,%)
  1.  Q
  1. P6 ;EP - from KIDS
  1.  Q:'$G(XPDQUES("POS9"))
  1.  ;
  1.  ; ---Denial APPEAL option
  1.  S %="P6OPT^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS9-"_%,%)
  1.  ;
  1.  ; --- Re-index non-reg pat name
  1.  S %="NONREG^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS10-"_%,%)
  1.  ;
  1.  ; --- Set appeal status if denial reversed.
  1.  S %="DENREV^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS11-"_%,%)
  1.  Q
  1.  ;
  1. P7 ;EP-from KIDS
  1.  Q:'$G(XPDQUES("POS12"))
  1.  ;
  1.  ; --REMOVE OLD DD FR V1.45 
  1.  S %="V145DD^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS12-"_%,%)
  1.  ;
  1.  ; ---E SIG OPTIONS
  1.  S %="P7OPT^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS13-"_%,%)
  1.  Q
  1.  ;
  1. P12 ;EP-fr KIDS
  1.  Q:$$INSTALLD("ACHS*3.1*12")
  1.  S %="TEST^ACHSPQTS"
  1.  I $$NEWCP^XPDUTL("POS15-"_%,%)
  1.  ;
  1.  S %="HHS^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS16-"_%,%)
  1.  Q
  1. P13 ;EP-fr KIDS
  1.  Q:$$INSTALLD("ACHS*3.1*13")
  1.  S %="UFMS^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS17-"_%,%)
  1.  Q
  1. P14 ;EP-fr KIDS
  1.  Q:$$INSTALLD("ACHS*3.1*14")
  1.  S %="DCIS^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS18-"_%,%)
  1. P15 ;EP-fr KIDS
  1.  Q:$$INSTALLD("ACHS*3.1*15")
  1.  S %="ZISHOS^ACHS3115"
  1.  I $$NEWCP^XPDUTL("POS19-"_%,%)
  1.  Q