ACHS3118 ;IHS/OIT/FCJ - ACHS 3.1 PATCH 18 ;7/30/10 08:37
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18**;JUNE 11,2001
;3.1*16 12/1/2009;IHS/OIT/FCJ - ORIG RTN P15 MOVED ENV CHECK TO ACHS31E1
;
PRE ;EP - From KIDS.
I $$NEWCP^XPDUTL("PRE1","AUDS^ACHS3118")
Q
;
POST ;EP - From KIDS.
; --Patches 4,5,6,7 Checks installs in Kids Install Questions.
; --Question for 3 was removed, need "C" index for lookup of non-registered patients
S %="P4^ACHS3118"
I $$NEWCP^XPDUTL("POS4-"_%,%)
S %="P5^ACHS3118"
I $$NEWCP^XPDUTL("POS5-"_%,%)
S %="P6^ACHS3118"
I $$NEWCP^XPDUTL("POS9-"_%,%)
S %="P7^ACHS3118"
I $$NEWCP^XPDUTL("POS12-"_%,%)
;PATCH 12
S %="P12^ACHS3118"
I $$NEWCP^XPDUTL("POS14-"_%,%)
;PATCH 13
S %="P13^ACHS3118"
I $$NEWCP^XPDUTL("POS17-"_%,%)
;PATCH 14
S %="P14^ACHS3118"
I $$NEWCP^XPDUTL("POS18-"_%,%)
;PATCH 15
S %="P15^ACHS3118"
I $$NEWCP^XPDUTL("POS19-"_%,%)
;PATCH 16
S %="P16^ACHS3118"
I $$NEWCP^XPDUTL("POS20-"_%,%)
;PATCH 18
S %="P18^ACHS3118"
I $$NEWCP^XPDUTL("POS21-"_%,%)
; --- Restore dd audit settings.
S %="AUDR^ACHS3118"
I $$NEWCP^XPDUTL("POS22-"_%,%)
; --- Send mail message of install.
S %="MAIL^ACHS3118"
I $$NEWCP^XPDUTL("POS23-"_%,%)
;
Q
MAIL ;
D BMES^XPDUTL("BEGIN Delivering MailMan message to select users.")
NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
KILL ^TMP("ACHS3118",$J)
D RSLT(" --- ACHS v 3.1 Patch 15, 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(""ACHS3118"",$J,",XMY(1)="",XMY(DUZ)=""
F %="ACHSZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)
D ^XMD
KILL ^TMP("ACHS3118",$J)
D MES^XPDUTL("END Delivering MailMan message to select users.")
Q
;
RSLT(%) S ^(0)=$G(^TMP("ACHS3118",$J,0))+1,^(^(0))=%
Q
;
SINGLE(K) ; Get holders of a key
NEW Y
S Y=0
Q:'$D(^XUSEC(K))
F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)=""
Q
;
GREET ;;To add to mail message.
;;
;;Standard data dictionaries on your RPMS system have been updated.
;;
;;You are receiving this message because of the RPMS
;;security keys that you hold. This is for your information.
;;Do not respond to this message.
;;
;;Questions about this patch may be directed to
;;the ITSC Support Center, at 505-248-4371,
;;refer to patch "ACHS*3.1*18".
;;
;;###;NOTE: This line end of text.
; ---------------------------------------------
; The global location for dictionary audit is:
; ^DD(FILE,0,"DDA")
; value = "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("ACHS3118",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^"_$P($P($T(+1),";",2)," ",3,99)
NEW ACHS
S ACHS=0
F S ACHS=$O(^XTMP("XPDI",XPDA,"FIA",ACHS)) Q:'ACHS D
. I '$D(^XTMP("ACHS3118",ACHS,"DDA")) S ^XTMP("ACHS3118",ACHS,"DDA")=$G(^DD(ACHS,0,"DDA"))
. D MES^XPDUTL(" File "_$$RJ^XLFSTR(ACHS,12)_" - "_$$LJ^XLFSTR(^XTMP("XPDI",XPDA,"FIA",ACHS),30)_"- DD audit was '"_$G(^XTMP("ACHS3118",ACHS,"DDA"))_"'"),MES^XPDUTL($$RJ^XLFSTR("Set to 'Y'",69))
. S ^DD(ACHS,0,"DDA")="Y"
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 ACHS
S ACHS=0
F S ACHS=$O(^XTMP("ACHS3118",ACHS)) Q:'ACHS D
. S ^DD(ACHS,0,"DDA")=^XTMP("ACHS3118",ACHS,"DDA")
. D MES^XPDUTL(" File "_$$RJ^XLFSTR(ACHS,12)_" - "_$$LJ^XLFSTR($$GET1^DID(ACHS,"","","NAME"),30)_"- DD AUDIT Set to '"_^DD(ACHS,0,"DDA")_"'")
.Q
KILL ^XTMP("ACHS3118")
D MES^XPDUTL("DD AUDIT settings restored.")
Q
;
;Fields to be deleted.
;File#^FileName^Field#^FieldName
DELFLD ;
;;9002069^CHS DATA CONTROL^1^*RESERVED-1
;;9002069^CHS DATA CONTROL^3^*BUDGET INDIVIDUAL ACCOU
;;9002069.03^PIGGYBACK FACILITIES^.01^PIGGYBACK FACILITIES
;;9002069^CHS DATA CONTROL^9^*PIGGYBACK FACILITIES
;;9002071.63^* DIAGNOSIS (APC) COMMENT^.01^* DIAGNOSIS (APC) COMMENT
;;9002071.06^* DIAGNOSIS (APC)^.01^* DIAGNOSIS (APC)
;;9002071.06^* DIAGNOSIS (APC)^2^* DIAGNOSIS (APC) NARRATIVE
;;9002071.06^* DIAGNOSIS (APC)^3^* DIAGNOSIS (APC) COMMENT
;;9002071.01^DENIAL NUMBER^600^* DIAGNOSIS (APC)
;;9002080^CHS FACILITY^14.1^*PROCESS PAT FOR AREA NC
;;9002080^CHS FACILITY^14.13^*PROCESS DOCUMENT RECS F
;;9002080.01^DOCUMENT^13.66^* VEND AGR NUMB (NOT USE
;;9002080.01^DOCUMENT^77^*DENTAL SERVICES
;;END
; Above line ends loop
D BMES^XPDUTL("BEGIN Removing deleted fields from CHS Files.")
NEW DA,DIK
F ACHS=1:1 S X=$P($T(DELFLD+ACHS),";",3) Q:X="END" D
.D MES^XPDUTL($J("",5)_"Deleting '"_$$LJ^XLFSTR($P(X,U,4),30,".")_"' from '"_$P(X,U,2)_"'")
.S DIK="^DD("_$P(X,U,1)_",",DA(1)=$P(X,U,1),DA=$P(X,U,3)
.D ^DIK
.; KILL ^DD(9999999.3911) ; 4 of the 0th nodes aren't KILL'd by ^DIK.
D MES^XPDUTL("END Removing deleted fields from CHS Files.")
Q
;
DENOPT ;638 facility then add options
D BMES^XPDUTL("BEGIN Checking for 638 facility.")
NEW ACHS
S ACHS=0
F S ACHS=$O(^ACHSF(ACHS)) Q:'ACHS I $P(^ACHSF(ACHS,0),U,8)="Y" D Q
.I $$ADD^XPDMENU("ACHS DEFDEN MENU PARM","ACHSDENPARM","P638") D MES^XPDUTL($J("",5)_"Denial par menu added for 638 facility")
.I $$ADD^XPDMENU("ACHSDENPARM","ACHSDENPARMREA","AREA") D MES^XPDUTL($J("",5)_"Denial par menu added for 638 facility")
D MES^XPDUTL("END Checking for 638 facility.")
Q
;
M278 ;
D BMES^XPDUTL("BEGIN Attaching 278 menu.")
I $$ADD^XPDMENU("ACHSAA","ACHS 278 MENU","278") D MES^XPDUTL($J("",5)_"278 Menu added to Doc Gen menu."),MES^XPDUTL($J("",5)_"Note that the security lock was *NOT* allocated.") I 1
E D MES^XPDUTL($J("",5)_"ERROR: 278 menu attachment FAILED.")
D MES^XPDUTL("END Attaching 278 menu.")
Q
;
P6OPT ;EP - FR KIDS
;ADD NEW OPTIONS - P 6, DENIAL APPEAL,EDITS AND CANCEL, FI FIELD
D BMES^XPDUTL("Begin adding new options.")
I $$ADD^XPDMENU("ACHSAA","ACHSFIM","FIM") D MES^XPDUTL($J("",5)_"Approval Message to FI added to Doc Gen Menu")
;I $$ADD^XPDMENU("ACHS DEFDEN MENU","ACHS DEN APPEAL MENU","APP") D MES^XPDUTL($J("",5)_"Denial Appeal menu added to CHS Denial/Deferred Servcies Menu")
D MES^XPDUTL("END updating options.")
Q
NONREG ;EP - fr KIDS
D BMES^XPDUTL("BEGIN Re-index of Patient Name in Denials.")
NEW ACHS,DA,DIK
S ACHS=0
F S ACHS=$O(^ACHSDEN(ACHS)) Q:'ACHS D
.K ^ACHSDEN(ACHS,"D","C"),^ACHSDEN(ACHS,"D","N")
.S DIK="^ACHSDEN("_ACHS_",""D"""_",",DA(1)=ACHS
.F DIK(1)="7^C","10^C" D ENALL^DIK
D MES^XPDUTL("END Re-index of Patient Name in Denials.")
Q
DENREV ;EP - Fr KIDS
;SETS DEN STATUS IF DEN WAS REVERSED
NEW ACHS
S ACHSASTA=0,ACHSDA=0,ACHS=0
S ACHSASTA=$O(^ACHSDENA("B","REVERSED AFTER APPEAL",ACHSASTA))
F S ACHS=$O(^ACHSDEN(ACHS)) Q:ACHS'?1N.N D
.S ACHSDA=0
.F S ACHSDA=$O(^ACHSDEN(ACHS,"D",ACHSDA)) Q:ACHSDA'?1N.N D
..S ACHSDSTA=$P(^ACHSDEN(ACHS,"D",ACHSDA,0),U,8)
..Q:'$D(^ACHSDEN(ACHS,"D",ACHSDA,400,0))
..I ACHSDSTA["R" S $P(^ACHSDEN(ACHS,"D",ACHSDA,400,0),U,3)=ACHSASTA
K ACHSASTA,ACHSDA
Q
V145DD ;EP - FR KIDS
;Removes V 1.45 DD'S LEFT BEHIND
K ^UTILITY("XBDSET",$J)
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
K XBBPI,XBBPIX,XBBPIY D EN2^XBKD
Q
LIST ;
;;^UTILITY("XBDSET",$J,1803100)=S^S
;;^UTILITY("XBDSET",$J,1803101)=S^S
;;^UTILITY("XBDSET",$J,1803102)=S^S
;;^UTILITY("XBDSET",$J,1803103)=S^S
;;^UTILITY("XBDSET",$J,1803104)=S^S
;;^UTILITY("XBDSET",$J,1803107)=S^S
;;^UTILITY("XBDSET",$J,1803109)=S^S
;;^UTILITY("XBDSET",$J,1803110)=S^S
;;^UTILITY("XBDSET",$J,1803111)=S^S
;;^UTILITY("XBDSET",$J,1803112)=S^S
;;^UTILITY("XBDSET",$J,1803113)=S^S
;;^UTILITY("XBDSET",$J,1803114)=S^S
;;^UTILITY("XBDSET",$J,1803115)=S^S
;;END
;Above line ends loop
;
P7OPT ;EP -FR KIDS
;NEW OPTIONS P7 E-SIG & REPORTS
D BMES^XPDUTL("Adding new options.")
I $$ADD^XPDMENU("ACHSMENU","ACHS E-SIG MENU","EMNU") D MES^XPDUTL($J("",5)_"Electronic Signature Auth Menu to CHS Menu")
I $$ADD^XPDMENU("ACHS E-SIG MENU","ACHS E-SIG AUTHORIZING OFC.","SIGA")
I $$ADD^XPDMENU("ACHS E-SIG MENU","ACHS E-SIG ORDERING OFC.","SIGO") D MES^XPDUTL($J("",5)_"Electronic Sig for Authorizing Official, Electronic Sig for Ordering Official")
I $$ADD^XPDMENU("ACHSREPORTS","ACHS E-SIG REPORTS","ERPT")
I $$ADD^XPDMENU("ACHS E-SIG REPORTS","ACHS E-SIG APPROVED REPORT","ESAP")
I $$ADD^XPDMENU("ACHS E-SIG REPORTS","ACHS E-SIG PENDING SIG REPORT","ESPD")
D MES^XPDUTL($J("",5)_"Options in E-Signature Reports added")
I $$ADD^XPDMENU("ACHSMGPAR","ACHS E-SIG ADD EDIT USERS","EOFF")
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")
I $$ADD^XPDMENU("ACHSMGR","ACHSMGPAR") D MES^XPDUTL($J("",5)_"Attach E-Sig to facility Management")
D MES^XPDUTL("Key for E-Sig Menu is ACHSZESIG,for Adding authorized users is ACHSZPARM.")
D MES^XPDUTL("END updating options.")
Q
;
HHS ;
D BMES^XPDUTL("BEGIN Checking for IHS facility.")
N ACHSI
S ACHSI=0
F S ACHSI=$O(^ACHSF(ACHSI)) Q:ACHSI'?1N.N I $P(^ACHSF(ACHSI,0),U,8)'="Y" D Q
.I $$ADD^XPDMENU("ACHSMGR","ACHSHHS","HHS") D MES^XPDUTL($J("",5)_"HHS Contract Action Type edit added for IHS facilities")
D MES^XPDUTL("END Checking for IHS facilities.")
Q
UFMS ;EP-fr KIDS P 13
;ADD UFMS START DATE TO CHS FAC FILE
S X=0 F S X=$O(^ACHSF("B",X)) Q:X'?1N.N D
.S X1=0 F S X1=$O(^ACHSF("B",X,X1)) Q:X1'?1N.N D
..S:$P(^ACHSF(X1,0),U,8)="N" $P(^ACHSF(X1,0),U,13)=3071001
;ADD IE SERVER TO ZISH SEND PAR
S X="ACHS UFMS B",DIC="^%ZIB(9888888.93,",DIC(0)="L"
D ^DIC
I Y<0 W !,"ZISH SEND PARAMETER FOR THE ACHS UFMS ENTRY COULD NOT BE ADDED, YOU WILL NEED TO THROUGH FILEMAN" Q
S DA=+Y,DIE=DIC
S DR=".02////"_"quovadx-ie.ihs.gov"_";.03////"_"ufmsuser"_";.04////"_"vjrsshn9"_";.06////"_"-iau"_";.07////"_"B"_";.08////"_"sendto"
D ^DIE
K D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM,DA
Q
DCIS ;EP-FR kids P14
N X,Y
S ACHSUNM="",ACHSUNM=$S($$OS^ACHS=1:"D1/WEBFRS_CHS",1:"D1\WEBFRS_CHS")
S X="ACHS WEBFRS B",DIC="^%ZIB(9888888.93,",DIC(0)="L"
D ^DIC
I Y<0 W !,"ZISH SEND PARAMETER FOR THE ACHS WEBFRS ENTRY COULD NOT BE ADDED, YOU WILL NEED TO EDIT USING FILEMAN" Q
S DA=+Y,DIE=DIC
S DR=".02////"_"INTRANETFTP.IHS.GOV"_";.03////"_ACHSUNM_";.04////"_"oFRkd9UXaIIob0e"_";.06////"_"-iaun"_";.07////"_"B"_";.08////"_"sendto"
D ^DIE
K D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM,DA,ACHSUNM
SSC ;ADD NAICS CODES TO SSC P14
S ACHSFAC=""
F S ACHSFAC=$O(^ACHS(3,"B",ACHSFAC)) Q:ACHSFAC'?1N.N D
.S ACHSSSC="" F S ACHSSSC=$O(^ACHS(3,ACHSFAC,1,"B",ACHSSSC)) Q:ACHSSSC="" D
..S X=""
..I (ACHSSSC=2185)!(ACHSSSC=4319) S X=621999
..I (ACHSSSC="252A")!(ACHSSSC="252B") S X=621511
..I (ACHSSSC="252D") S X=339116
..I (ACHSSSC="252G")!(ACHSSSC="252L")!(ACHSSSC="252Q") S X=622110
..I (ACHSSSC="252M") S X=623110
..I (ACHSSSC="252S") S X=621340
..I (ACHSSSC="252H")!(ACHSSSC="252J") S X=621512
..I (ACHSSSC="254A")!(ACHSSSC="254B")!(ACHSSSC="254C")!(ACHSSSC="254D") S X=621111
..I (ACHSSSC="254E") S X=621210
..I (ACHSSSC="254G")!(ACHSSSC="254J") S X=622310
..I (ACHSSSC="254L")!(ACHSSSC="263K") S X=621320
..I (ACHSSSC="253A")!(ACHSSSC="253G") S X=621999
..I (ACHSSSC="263L") S X=621340
..Q:X=""
..S DIC="^ACHS(3.1," D ^DIC
..S X="" S X=$O(^ACHS(3,ACHSFAC,1,"B",ACHSSSC,X))
..S $P(^ACHS(3,ACHSFAC,1,X,0),U,6)=$P(Y,U)
Q
ZISHOS ;EP-P 15 IF OS=UNIX UPDATE PAR TO NOT SEND ZIPPED FILE
I $$OS^ACHS=1 D
.S X="ACHS WEBFRS B",(DIE,DIC)="^%ZIB(9888888.93,"
.D ^DIC
.I Y<0 W !,"ACHS WEBFRS B ZISH PARAMETER ENTRY NOT FOUND, FEDERAL SITES-ENTRY IS REQUIRED." Q
.S DA=+Y,DR=".06////"_"-iaun" D ^DIE
.K D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM,Y,X
DRPT ;ADD DCIS ERROR REPORT OPT P15
I $$ADD^XPDMENU("ACHSREPORTS","ACHSRPTDCISERROR","DCIS") D MES^XPDUTL($J("",5)_"DCIS Error Report Option added to the Report Menu")
Q
P4 ;EP - fr KIDS
Q:'$G(XPDQUES("POS4"))
D BMES^XPDUTL("BEGIN Re-index of Pat Name in Deferred Services.")
NEW ACHS,DA,DIK
S ACHS=0
F S ACHS=$O(^ACHSDEF(ACHS)) Q:'ACHS D
.K ^ACHSDEF(ACHS,"D","C"),^ACHSDEF(ACHS,"D","N")
.S DIK="^ACHSDEF("_ACHS_",""D"""_",",DA(1)=ACHS
.F DIK(1)="6^C","7^N" D ENALL^DIK
D MES^XPDUTL("END Re-index of Pat Name.")
Q
;
P5 ;EP - from KIDS
Q:'$G(XPDQUES("POS5"))
; ---Denial ltr edit option
S %="DENOPT^ACHS3118"
I $$NEWCP^XPDUTL("POS5-"_%,%)
; ---Del fields in CHS files marked for deletion
S %="DELFLD^ACHS3118"
I $$NEWCP^XPDUTL("POS6-"_%,%)
; --- 278 menu
S %="M278^ACHS3118"
I $$NEWCP^XPDUTL("POS7-"_%,%)
; ---Remove non-standard opt auditing from CHS
S %="POS^ACHS31P0"
I $$NEWCP^XPDUTL("POS8-"_%,%)
Q
P6 ;EP - from KIDS
Q:'$G(XPDQUES("POS9"))
; ---Denial APPEAL option
S %="P6OPT^ACHS3118"
I $$NEWCP^XPDUTL("POS9-"_%,%)
; --- Re-index non-reg pat name
S %="NONREG^ACHS3118"
I $$NEWCP^XPDUTL("POS10-"_%,%)
; --- Set appeal status.
S %="DENREV^ACHS3118"
I $$NEWCP^XPDUTL("POS11-"_%,%)
Q
P7 ;EP-from KIDS
Q:'$G(XPDQUES("POS12"))
; --REMOVE OLD DD FR V1.45
S %="V145DD^ACHS3118"
I $$NEWCP^XPDUTL("POS12-"_%,%)
; ---E SIG OPTIONS
S %="P7OPT^ACHS3118"
I $$NEWCP^XPDUTL("POS13-"_%,%)
Q
P12 ;EP-fr KIDS
Q:$$INSTALLD^ACHS31E1("ACHS*3.1*12")
S %="TEST^ACHSPQTS"
I $$NEWCP^XPDUTL("POS15-"_%,%)
;
S %="HHS^ACHS3118"
I $$NEWCP^XPDUTL("POS16-"_%,%)
Q
P13 ;EP-fr KIDS
Q:$$INSTALLD^ACHS31E1("ACHS*3.1*13")
S %="UFMS^ACHS3118"
I $$NEWCP^XPDUTL("POS17-"_%,%)
Q
P14 ;EP-fr KIDS
Q:$$INSTALLD^ACHS31E1("ACHS*3.1*14")
S %="DCIS^ACHS3118"
I $$NEWCP^XPDUTL("POS18-"_%,%)
Q
P15 ;EP-fr KIDS
Q:$$INSTALLD^ACHS31E1("ACHS*3.1*15")
S %="ZISHOS^ACHS3118"
I $$NEWCP^XPDUTL("POS19-"_%,%)
Q
P16 ;EP-fr KIDS
Q:$$INSTALLD^ACHS31E1("ACHS*3.1*16")
S %="P16OPT^ACHS118A"
I $$NEWCP^XPDUTL("POS20-"_%,%)
Q
P18 ;EP-fr KIDS
S %="P18OPT^ACHS118A"
I $$NEWCP^XPDUTL("POS21-"_%,%)
Q
ACHS3118 ;IHS/OIT/FCJ - ACHS 3.1 PATCH 18 ;7/30/10 08:37
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18**;JUNE 11,2001
+2 ;3.1*16 12/1/2009;IHS/OIT/FCJ - ORIG RTN P15 MOVED ENV CHECK TO ACHS31E1
+3 ;
PRE ;EP - From KIDS.
+1 IF $$NEWCP^XPDUTL("PRE1","AUDS^ACHS3118")
+2 QUIT
+3 ;
POST ;EP - From KIDS.
+1 ; --Patches 4,5,6,7 Checks installs in Kids Install Questions.
+2 ; --Question for 3 was removed, need "C" index for lookup of non-registered patients
+3 SET %="P4^ACHS3118"
+4 IF $$NEWCP^XPDUTL("POS4-"_%,%)
+5 SET %="P5^ACHS3118"
+6 IF $$NEWCP^XPDUTL("POS5-"_%,%)
+7 SET %="P6^ACHS3118"
+8 IF $$NEWCP^XPDUTL("POS9-"_%,%)
+9 SET %="P7^ACHS3118"
+10 IF $$NEWCP^XPDUTL("POS12-"_%,%)
+11 ;PATCH 12
+12 SET %="P12^ACHS3118"
+13 IF $$NEWCP^XPDUTL("POS14-"_%,%)
+14 ;PATCH 13
+15 SET %="P13^ACHS3118"
+16 IF $$NEWCP^XPDUTL("POS17-"_%,%)
+17 ;PATCH 14
+18 SET %="P14^ACHS3118"
+19 IF $$NEWCP^XPDUTL("POS18-"_%,%)
+20 ;PATCH 15
+21 SET %="P15^ACHS3118"
+22 IF $$NEWCP^XPDUTL("POS19-"_%,%)
+23 ;PATCH 16
+24 SET %="P16^ACHS3118"
+25 IF $$NEWCP^XPDUTL("POS20-"_%,%)
+26 ;PATCH 18
+27 SET %="P18^ACHS3118"
+28 IF $$NEWCP^XPDUTL("POS21-"_%,%)
+29 ; --- Restore dd audit settings.
+30 SET %="AUDR^ACHS3118"
+31 IF $$NEWCP^XPDUTL("POS22-"_%,%)
+32 ; --- Send mail message of install.
+33 SET %="MAIL^ACHS3118"
+34 IF $$NEWCP^XPDUTL("POS23-"_%,%)
+35 ;
+36 QUIT
MAIL ;
+1 DO BMES^XPDUTL("BEGIN Delivering MailMan message to select users.")
+2 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+3 KILL ^TMP("ACHS3118",$JOB)
+4 DO RSLT(" --- ACHS v 3.1 Patch 15, 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(""ACHS3118"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+9 FOR %="ACHSZMENU","XUMGR","XUPROG","XUPROGMODE"
DO SINGLE(%)
+10 DO ^XMD
+11 KILL ^TMP("ACHS3118",$JOB)
+12 DO MES^XPDUTL("END Delivering MailMan message to select users.")
+13 QUIT
+14 ;
RSLT(%) SET ^(0)=$GET(^TMP("ACHS3118",$JOB,0))+1
SET ^(^(0))=%
+1 QUIT
+2 ;
SINGLE(K) ; Get holders of a key
+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 ;
GREET ;;To add to mail message.
+1 ;;
+2 ;;Standard data dictionaries on your RPMS system have been updated.
+3 ;;
+4 ;;You are receiving this message because of the RPMS
+5 ;;security keys that you hold. This is for your information.
+6 ;;Do not respond to this message.
+7 ;;
+8 ;;Questions about this patch may be directed to
+9 ;;the ITSC Support Center, at 505-248-4371,
+10 ;;refer to patch "ACHS*3.1*18".
+11 ;;
+12 ;;###;NOTE: This line end of text.
+13 ; ---------------------------------------------
+14 ; The global location for dictionary audit is:
+15 ; ^DD(FILE,0,"DDA")
+16 ; value = "Y", dd audit is on. Any other value, or the
+17 ; absence of the node, means dd audit is off.
+18 ;
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("ACHS3118",0)=$$FMADD^XLFDT(DT,10)_"^"_DT_"^"_$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
+4 NEW ACHS
+5 SET ACHS=0
+6 FOR
SET ACHS=$ORDER(^XTMP("XPDI",XPDA,"FIA",ACHS))
IF 'ACHS
QUIT
Begin DoDot:1
+7 IF '$DATA(^XTMP("ACHS3118",ACHS,"DDA"))
SET ^XTMP("ACHS3118",ACHS,"DDA")=$GET(^DD(ACHS,0,"DDA"))
+8 DO MES^XPDUTL(" File "_$$RJ^XLFSTR(ACHS,12)_" - "_$$LJ^XLFSTR(^XTMP("XPDI",XPDA,"FIA",ACHS),30)_"- DD audit was '"_$GET(^XTMP("ACHS3118",ACHS,"DDA"))_"'")
DO MES^XPDUTL($$RJ^XLFSTR("Set to 'Y'",69))
+9 SET ^DD(ACHS,0,"DDA")="Y"
End DoDot:1
+10 DO MES^XPDUTL("DD AUDIT settings saved in ^XTMP(.")
+11 QUIT
+12 ;
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 ACHS
+3 SET ACHS=0
+4 FOR
SET ACHS=$ORDER(^XTMP("ACHS3118",ACHS))
IF 'ACHS
QUIT
Begin DoDot:1
+5 SET ^DD(ACHS,0,"DDA")=^XTMP("ACHS3118",ACHS,"DDA")
+6 DO MES^XPDUTL(" File "_$$RJ^XLFSTR(ACHS,12)_" - "_$$LJ^XLFSTR($$GET1^DID(ACHS,"","","NAME"),30)_"- DD AUDIT Set to '"_^DD(ACHS,0,"DDA")_"'")
+7 QUIT
End DoDot:1
+8 KILL ^XTMP("ACHS3118")
+9 DO MES^XPDUTL("DD AUDIT settings restored.")
+10 QUIT
+11 ;
+12 ;Fields to be deleted.
+13 ;File#^FileName^Field#^FieldName
DELFLD ;
+1 ;;9002069^CHS DATA CONTROL^1^*RESERVED-1
+2 ;;9002069^CHS DATA CONTROL^3^*BUDGET INDIVIDUAL ACCOU
+3 ;;9002069.03^PIGGYBACK FACILITIES^.01^PIGGYBACK FACILITIES
+4 ;;9002069^CHS DATA CONTROL^9^*PIGGYBACK FACILITIES
+5 ;;9002071.63^* DIAGNOSIS (APC) COMMENT^.01^* DIAGNOSIS (APC) COMMENT
+6 ;;9002071.06^* DIAGNOSIS (APC)^.01^* DIAGNOSIS (APC)
+7 ;;9002071.06^* DIAGNOSIS (APC)^2^* DIAGNOSIS (APC) NARRATIVE
+8 ;;9002071.06^* DIAGNOSIS (APC)^3^* DIAGNOSIS (APC) COMMENT
+9 ;;9002071.01^DENIAL NUMBER^600^* DIAGNOSIS (APC)
+10 ;;9002080^CHS FACILITY^14.1^*PROCESS PAT FOR AREA NC
+11 ;;9002080^CHS FACILITY^14.13^*PROCESS DOCUMENT RECS F
+12 ;;9002080.01^DOCUMENT^13.66^* VEND AGR NUMB (NOT USE
+13 ;;9002080.01^DOCUMENT^77^*DENTAL SERVICES
+14 ;;END
+15 ; Above line ends loop
+16 DO BMES^XPDUTL("BEGIN Removing deleted fields from CHS Files.")
+17 NEW DA,DIK
+18 FOR ACHS=1:1
SET X=$PIECE($TEXT(DELFLD+ACHS),";",3)
IF X="END"
QUIT
Begin DoDot:1
+19 DO MES^XPDUTL($JUSTIFY("",5)_"Deleting '"_$$LJ^XLFSTR($PIECE(X,U,4),30,".")_"' from '"_$PIECE(X,U,2)_"'")
+20 SET DIK="^DD("_$PIECE(X,U,1)_","
SET DA(1)=$PIECE(X,U,1)
SET DA=$PIECE(X,U,3)
+21 DO ^DIK
+22 ; KILL ^DD(9999999.3911) ; 4 of the 0th nodes aren't KILL'd by ^DIK.
End DoDot:1
+23 DO MES^XPDUTL("END Removing deleted fields from CHS Files.")
+24 QUIT
+25 ;
DENOPT ;638 facility then add options
+1 DO BMES^XPDUTL("BEGIN Checking for 638 facility.")
+2 NEW ACHS
+3 SET ACHS=0
+4 FOR
SET ACHS=$ORDER(^ACHSF(ACHS))
IF 'ACHS
QUIT
IF $PIECE(^ACHSF(ACHS,0),U,8)="Y"
Begin DoDot:1
+5 IF $$ADD^XPDMENU("ACHS DEFDEN MENU PARM","ACHSDENPARM","P638")
DO MES^XPDUTL($JUSTIFY("",5)_"Denial par menu added for 638 facility")
+6 IF $$ADD^XPDMENU("ACHSDENPARM","ACHSDENPARMREA","AREA")
DO MES^XPDUTL($JUSTIFY("",5)_"Denial par menu added for 638 facility")
End DoDot:1
QUIT
+7 DO MES^XPDUTL("END Checking for 638 facility.")
+8 QUIT
+9 ;
M278 ;
+1 DO BMES^XPDUTL("BEGIN Attaching 278 menu.")
+2 IF $$ADD^XPDMENU("ACHSAA","ACHS 278 MENU","278")
DO MES^XPDUTL($JUSTIFY("",5)_"278 Menu added to Doc Gen menu.")
DO MES^XPDUTL($JUSTIFY("",5)_"Note that the security lock was *NOT* allocated.")
IF 1
+3 IF '$TEST
DO MES^XPDUTL($JUSTIFY("",5)_"ERROR: 278 menu attachment FAILED.")
+4 DO MES^XPDUTL("END Attaching 278 menu.")
+5 QUIT
+6 ;
P6OPT ;EP - FR KIDS
+1 ;ADD NEW OPTIONS - P 6, DENIAL APPEAL,EDITS AND CANCEL, FI FIELD
+2 DO BMES^XPDUTL("Begin adding new options.")
+3 IF $$ADD^XPDMENU("ACHSAA","ACHSFIM","FIM")
DO MES^XPDUTL($JUSTIFY("",5)_"Approval Message to FI added to Doc Gen Menu")
+4 ;I $$ADD^XPDMENU("ACHS DEFDEN MENU","ACHS DEN APPEAL MENU","APP") D MES^XPDUTL($J("",5)_"Denial Appeal menu added to CHS Denial/Deferred Servcies Menu")
+5 DO MES^XPDUTL("END updating options.")
+6 QUIT
NONREG ;EP - fr KIDS
+1 DO BMES^XPDUTL("BEGIN Re-index of Patient Name in Denials.")
+2 NEW ACHS,DA,DIK
+3 SET ACHS=0
+4 FOR
SET ACHS=$ORDER(^ACHSDEN(ACHS))
IF 'ACHS
QUIT
Begin DoDot:1
+5 KILL ^ACHSDEN(ACHS,"D","C"),^ACHSDEN(ACHS,"D","N")
+6 SET DIK="^ACHSDEN("_ACHS_",""D"""_","
SET DA(1)=ACHS
+7 FOR DIK(1)="7^C","10^C"
DO ENALL^DIK
End DoDot:1
+8 DO MES^XPDUTL("END Re-index of Patient Name in Denials.")
+9 QUIT
DENREV ;EP - Fr KIDS
+1 ;SETS DEN STATUS IF DEN WAS REVERSED
+2 NEW ACHS
+3 SET ACHSASTA=0
SET ACHSDA=0
SET ACHS=0
+4 SET ACHSASTA=$ORDER(^ACHSDENA("B","REVERSED AFTER APPEAL",ACHSASTA))
+5 FOR
SET ACHS=$ORDER(^ACHSDEN(ACHS))
IF ACHS'?1N.N
QUIT
Begin DoDot:1
+6 SET ACHSDA=0
+7 FOR
SET ACHSDA=$ORDER(^ACHSDEN(ACHS,"D",ACHSDA))
IF ACHSDA'?1N.N
QUIT
Begin DoDot:2
+8 SET ACHSDSTA=$PIECE(^ACHSDEN(ACHS,"D",ACHSDA,0),U,8)
+9 IF '$DATA(^ACHSDEN(ACHS,"D",ACHSDA,400,0))
QUIT
+10 IF ACHSDSTA["R"
SET $PIECE(^ACHSDEN(ACHS,"D",ACHSDA,400,0),U,3)=ACHSASTA
End DoDot:2
End DoDot:1
+11 KILL ACHSASTA,ACHSDA
+12 QUIT
V145DD ;EP - FR KIDS
+1 ;Removes V 1.45 DD'S LEFT BEHIND
+2 KILL ^UTILITY("XBDSET",$JOB)
+3 FOR XBBPI=1:1
SET XBBPIX=$PIECE($TEXT(LIST+XBBPI),";;",2)
IF XBBPIX="END"
QUIT
SET XBBPIY=$PIECE(XBBPIX,"=",2,99)
SET XBBPIX=$PIECE(XBBPIX,"=",1)
SET @XBBPIX=XBBPIY
+4 KILL XBBPI,XBBPIX,XBBPIY
DO EN2^XBKD
+5 QUIT
LIST ;
+1 ;;^UTILITY("XBDSET",$J,1803100)=S^S
+2 ;;^UTILITY("XBDSET",$J,1803101)=S^S
+3 ;;^UTILITY("XBDSET",$J,1803102)=S^S
+4 ;;^UTILITY("XBDSET",$J,1803103)=S^S
+5 ;;^UTILITY("XBDSET",$J,1803104)=S^S
+6 ;;^UTILITY("XBDSET",$J,1803107)=S^S
+7 ;;^UTILITY("XBDSET",$J,1803109)=S^S
+8 ;;^UTILITY("XBDSET",$J,1803110)=S^S
+9 ;;^UTILITY("XBDSET",$J,1803111)=S^S
+10 ;;^UTILITY("XBDSET",$J,1803112)=S^S
+11 ;;^UTILITY("XBDSET",$J,1803113)=S^S
+12 ;;^UTILITY("XBDSET",$J,1803114)=S^S
+13 ;;^UTILITY("XBDSET",$J,1803115)=S^S
+14 ;;END
+15 ;Above line ends loop
+16 ;
P7OPT ;EP -FR KIDS
+1 ;NEW OPTIONS P7 E-SIG & REPORTS
+2 DO BMES^XPDUTL("Adding new options.")
+3 IF $$ADD^XPDMENU("ACHSMENU","ACHS E-SIG MENU","EMNU")
DO MES^XPDUTL($JUSTIFY("",5)_"Electronic Signature Auth Menu to CHS Menu")
+4 IF $$ADD^XPDMENU("ACHS E-SIG MENU","ACHS E-SIG AUTHORIZING OFC.","SIGA")
+5 IF $$ADD^XPDMENU("ACHS E-SIG MENU","ACHS E-SIG ORDERING OFC.","SIGO")
DO MES^XPDUTL($JUSTIFY("",5)_"Electronic Sig for Authorizing Official, Electronic Sig for Ordering Official")
+6 IF $$ADD^XPDMENU("ACHSREPORTS","ACHS E-SIG REPORTS","ERPT")
+7 IF $$ADD^XPDMENU("ACHS E-SIG REPORTS","ACHS E-SIG APPROVED REPORT","ESAP")
+8 IF $$ADD^XPDMENU("ACHS E-SIG REPORTS","ACHS E-SIG PENDING SIG REPORT","ESPD")
+9 DO MES^XPDUTL($JUSTIFY("",5)_"Options in E-Signature Reports added")
+10 IF $$ADD^XPDMENU("ACHSMGPAR","ACHS E-SIG ADD EDIT USERS","EOFF")
+11 IF $$ADD^XPDMENU("ACHSMGPAR","ACHS E-SIG SITE PARAMETER","ESIT")
DO MES^XPDUTL($JUSTIFY("",5)_"Option for adding Authorized E-Signature users and E-Site Paramaters added to facility management options")
+12 IF $$ADD^XPDMENU("ACHSMGR","ACHSMGPAR")
DO MES^XPDUTL($JUSTIFY("",5)_"Attach E-Sig to facility Management")
+13 DO MES^XPDUTL("Key for E-Sig Menu is ACHSZESIG,for Adding authorized users is ACHSZPARM.")
+14 DO MES^XPDUTL("END updating options.")
+15 QUIT
+16 ;
HHS ;
+1 DO BMES^XPDUTL("BEGIN Checking for IHS facility.")
+2 NEW ACHSI
+3 SET ACHSI=0
+4 FOR
SET ACHSI=$ORDER(^ACHSF(ACHSI))
IF ACHSI'?1N.N
QUIT
IF $PIECE(^ACHSF(ACHSI,0),U,8)'="Y"
Begin DoDot:1
+5 IF $$ADD^XPDMENU("ACHSMGR","ACHSHHS","HHS")
DO MES^XPDUTL($JUSTIFY("",5)_"HHS Contract Action Type edit added for IHS facilities")
End DoDot:1
QUIT
+6 DO MES^XPDUTL("END Checking for IHS facilities.")
+7 QUIT
UFMS ;EP-fr KIDS P 13
+1 ;ADD UFMS START DATE TO CHS FAC FILE
+2 SET X=0
FOR
SET X=$ORDER(^ACHSF("B",X))
IF X'?1N.N
QUIT
Begin DoDot:1
+3 SET X1=0
FOR
SET X1=$ORDER(^ACHSF("B",X,X1))
IF X1'?1N.N
QUIT
Begin DoDot:2
+4 IF $PIECE(^ACHSF(X1,0),U,8)="N"
SET $PIECE(^ACHSF(X1,0),U,13)=3071001
End DoDot:2
End DoDot:1
+5 ;ADD IE SERVER TO ZISH SEND PAR
+6 SET X="ACHS UFMS B"
SET DIC="^%ZIB(9888888.93,"
SET DIC(0)="L"
+7 DO ^DIC
+8 IF Y<0
WRITE !,"ZISH SEND PARAMETER FOR THE ACHS UFMS ENTRY COULD NOT BE ADDED, YOU WILL NEED TO THROUGH FILEMAN"
QUIT
+9 SET DA=+Y
SET DIE=DIC
+10 SET DR=".02////"_"quovadx-ie.ihs.gov"_";.03////"_"ufmsuser"_";.04////"_"vjrsshn9"_";.06////"_"-iau"_";.07////"_"B"_";.08////"_"sendto"
+11 DO ^DIE
+12 KILL D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM,DA
+13 QUIT
DCIS ;EP-FR kids P14
+1 NEW X,Y
+2 SET ACHSUNM=""
SET ACHSUNM=$SELECT($$OS^ACHS=1:"D1/WEBFRS_CHS",1:"D1\WEBFRS_CHS")
+3 SET X="ACHS WEBFRS B"
SET DIC="^%ZIB(9888888.93,"
SET DIC(0)="L"
+4 DO ^DIC
+5 IF Y<0
WRITE !,"ZISH SEND PARAMETER FOR THE ACHS WEBFRS ENTRY COULD NOT BE ADDED, YOU WILL NEED TO EDIT USING FILEMAN"
QUIT
+6 SET DA=+Y
SET DIE=DIC
+7 SET DR=".02////"_"INTRANETFTP.IHS.GOV"_";.03////"_ACHSUNM_";.04////"_"oFRkd9UXaIIob0e"_";.06////"_"-iaun"_";.07////"_"B"_";.08////"_"sendto"
+8 DO ^DIE
+9 KILL D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM,DA,ACHSUNM
SSC ;ADD NAICS CODES TO SSC P14
+1 SET ACHSFAC=""
+2 FOR
SET ACHSFAC=$ORDER(^ACHS(3,"B",ACHSFAC))
IF ACHSFAC'?1N.N
QUIT
Begin DoDot:1
+3 SET ACHSSSC=""
FOR
SET ACHSSSC=$ORDER(^ACHS(3,ACHSFAC,1,"B",ACHSSSC))
IF ACHSSSC=""
QUIT
Begin DoDot:2
+4 SET X=""
+5 IF (ACHSSSC=2185)!(ACHSSSC=4319)
SET X=621999
+6 IF (ACHSSSC="252A")!(ACHSSSC="252B")
SET X=621511
+7 IF (ACHSSSC="252D")
SET X=339116
+8 IF (ACHSSSC="252G")!(ACHSSSC="252L")!(ACHSSSC="252Q")
SET X=622110
+9 IF (ACHSSSC="252M")
SET X=623110
+10 IF (ACHSSSC="252S")
SET X=621340
+11 IF (ACHSSSC="252H")!(ACHSSSC="252J")
SET X=621512
+12 IF (ACHSSSC="254A")!(ACHSSSC="254B")!(ACHSSSC="254C")!(ACHSSSC="254D")
SET X=621111
+13 IF (ACHSSSC="254E")
SET X=621210
+14 IF (ACHSSSC="254G")!(ACHSSSC="254J")
SET X=622310
+15 IF (ACHSSSC="254L")!(ACHSSSC="263K")
SET X=621320
+16 IF (ACHSSSC="253A")!(ACHSSSC="253G")
SET X=621999
+17 IF (ACHSSSC="263L")
SET X=621340
+18 IF X=""
QUIT
+19 SET DIC="^ACHS(3.1,"
DO ^DIC
+20 SET X=""
SET X=$ORDER(^ACHS(3,ACHSFAC,1,"B",ACHSSSC,X))
+21 SET $PIECE(^ACHS(3,ACHSFAC,1,X,0),U,6)=$PIECE(Y,U)
End DoDot:2
End DoDot:1
+22 QUIT
ZISHOS ;EP-P 15 IF OS=UNIX UPDATE PAR TO NOT SEND ZIPPED FILE
+1 IF $$OS^ACHS=1
Begin DoDot:1
+2 SET X="ACHS WEBFRS B"
SET (DIE,DIC)="^%ZIB(9888888.93,"
+3 DO ^DIC
+4 IF Y<0
WRITE !,"ACHS WEBFRS B ZISH PARAMETER ENTRY NOT FOUND, FEDERAL SITES-ENTRY IS REQUIRED."
QUIT
+5 SET DA=+Y
SET DR=".06////"_"-iaun"
DO ^DIE
+6 KILL D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM,Y,X
End DoDot:1
DRPT ;ADD DCIS ERROR REPORT OPT P15
+1 IF $$ADD^XPDMENU("ACHSREPORTS","ACHSRPTDCISERROR","DCIS")
DO MES^XPDUTL($JUSTIFY("",5)_"DCIS Error Report Option added to the Report Menu")
+2 QUIT
P4 ;EP - fr KIDS
+1 IF '$GET(XPDQUES("POS4"))
QUIT
+2 DO BMES^XPDUTL("BEGIN Re-index of Pat Name in Deferred Services.")
+3 NEW ACHS,DA,DIK
+4 SET ACHS=0
+5 FOR
SET ACHS=$ORDER(^ACHSDEF(ACHS))
IF 'ACHS
QUIT
Begin DoDot:1
+6 KILL ^ACHSDEF(ACHS,"D","C"),^ACHSDEF(ACHS,"D","N")
+7 SET DIK="^ACHSDEF("_ACHS_",""D"""_","
SET DA(1)=ACHS
+8 FOR DIK(1)="6^C","7^N"
DO ENALL^DIK
End DoDot:1
+9 DO MES^XPDUTL("END Re-index of Pat Name.")
+10 QUIT
+11 ;
P5 ;EP - from KIDS
+1 IF '$GET(XPDQUES("POS5"))
QUIT
+2 ; ---Denial ltr edit option
+3 SET %="DENOPT^ACHS3118"
+4 IF $$NEWCP^XPDUTL("POS5-"_%,%)
+5 ; ---Del fields in CHS files marked for deletion
+6 SET %="DELFLD^ACHS3118"
+7 IF $$NEWCP^XPDUTL("POS6-"_%,%)
+8 ; --- 278 menu
+9 SET %="M278^ACHS3118"
+10 IF $$NEWCP^XPDUTL("POS7-"_%,%)
+11 ; ---Remove non-standard opt auditing from CHS
+12 SET %="POS^ACHS31P0"
+13 IF $$NEWCP^XPDUTL("POS8-"_%,%)
+14 QUIT
P6 ;EP - from KIDS
+1 IF '$GET(XPDQUES("POS9"))
QUIT
+2 ; ---Denial APPEAL option
+3 SET %="P6OPT^ACHS3118"
+4 IF $$NEWCP^XPDUTL("POS9-"_%,%)
+5 ; --- Re-index non-reg pat name
+6 SET %="NONREG^ACHS3118"
+7 IF $$NEWCP^XPDUTL("POS10-"_%,%)
+8 ; --- Set appeal status.
+9 SET %="DENREV^ACHS3118"
+10 IF $$NEWCP^XPDUTL("POS11-"_%,%)
+11 QUIT
P7 ;EP-from KIDS
+1 IF '$GET(XPDQUES("POS12"))
QUIT
+2 ; --REMOVE OLD DD FR V1.45
+3 SET %="V145DD^ACHS3118"
+4 IF $$NEWCP^XPDUTL("POS12-"_%,%)
+5 ; ---E SIG OPTIONS
+6 SET %="P7OPT^ACHS3118"
+7 IF $$NEWCP^XPDUTL("POS13-"_%,%)
+8 QUIT
P12 ;EP-fr KIDS
+1 IF $$INSTALLD^ACHS31E1("ACHS*3.1*12")
QUIT
+2 SET %="TEST^ACHSPQTS"
+3 IF $$NEWCP^XPDUTL("POS15-"_%,%)
+4 ;
+5 SET %="HHS^ACHS3118"
+6 IF $$NEWCP^XPDUTL("POS16-"_%,%)
+7 QUIT
P13 ;EP-fr KIDS
+1 IF $$INSTALLD^ACHS31E1("ACHS*3.1*13")
QUIT
+2 SET %="UFMS^ACHS3118"
+3 IF $$NEWCP^XPDUTL("POS17-"_%,%)
+4 QUIT
P14 ;EP-fr KIDS
+1 IF $$INSTALLD^ACHS31E1("ACHS*3.1*14")
QUIT
+2 SET %="DCIS^ACHS3118"
+3 IF $$NEWCP^XPDUTL("POS18-"_%,%)
+4 QUIT
P15 ;EP-fr KIDS
+1 IF $$INSTALLD^ACHS31E1("ACHS*3.1*15")
QUIT
+2 SET %="ZISHOS^ACHS3118"
+3 IF $$NEWCP^XPDUTL("POS19-"_%,%)
+4 QUIT
P16 ;EP-fr KIDS
+1 IF $$INSTALLD^ACHS31E1("ACHS*3.1*16")
QUIT
+2 SET %="P16OPT^ACHS118A"
+3 IF $$NEWCP^XPDUTL("POS20-"_%,%)
+4 QUIT
P18 ;EP-fr KIDS
+1 SET %="P18OPT^ACHS118A"
+2 IF $$NEWCP^XPDUTL("POS21-"_%,%)
+3 QUIT
