ACHS3114.m

ACHS3114 ;IHS/OIT/FCJ - ACHS 3.1 PATCH 14 ; JUL 10, 2008

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14**;JUNE 11,2001

 ;3.1*14 12/7/2006;IHS/OIT/FCJ - ORIG RTN P13

 ;               MOVED ENV CHECK TO ACHS31E1

 ;

PRE ;EP - From KIDS.

 I $$NEWCP^XPDUTL("PRE1","AUDS^ACHS3114")

 Q

 ;

POST ;EP - From KIDS.

 ; ---Patches 4,5,6,7 Checks installs are done in Install Questions.

 ; ---Question for 3 was removed, need "C" index for lookup of non-registered patients.

 S %="P4^ACHS3114"

 I $$NEWCP^XPDUTL("POS4-"_%,%)

 S %="P5^ACHS3114"

 I $$NEWCP^XPDUTL("POS5-"_%,%)

 ;

 S %="P6^ACHS3114"

 I $$NEWCP^XPDUTL("POS9-"_%,%)

 ;

 S %="P7^ACHS3114"

 I $$NEWCP^XPDUTL("POS12-"_%,%)

 ;

 ;PATCH 12

 S %="P12^ACHS3114"

 I $$NEWCP^XPDUTL("POS14-"_%,%)

 ;       

 ;PATCH 13

 S %="P13^ACHS3114"

 I $$NEWCP^XPDUTL("POS17-"_%,%)

 ;

 ;PATCH 14

 S %="P14^ACHS3114"

 I $$NEWCP^XPDUTL("POS18-"_%,%)

 ;

 ; --- Restore dd audit settings.

 S %="AUDR^ACHS3114"

 I $$NEWCP^XPDUTL("POS19-"_%,%)

 ;

 ; --- Send mail message of install.

 S %="MAIL^ACHS3114"

 I $$NEWCP^XPDUTL("POS20-"_%,%)

 ;

 Q

MAIL ;

 D BMES^XPDUTL("BEGIN Delivering MailMan message to select users.")

 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY

 KILL ^TMP("ACHS3114",$J)

 D RSLT(" --- ACHS v 3.1 Patch 14, has been installed into this uci ---")

 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(""ACHS3114"",$J,",XMY(1)="",XMY(DUZ)=""

 F %="ACHSZMENU","XUMGR","XUPROG","XUPROGMODE" D SINGLE(%)

 D ^XMD

 KILL ^TMP("ACHS3114",$J)

 D MES^XPDUTL("END Delivering MailMan message to select users.")

 Q

 ;

RSLT(%) S ^(0)=$G(^TMP("ACHS3114",$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

 ;

GREET ;;To add to mail message.

 ;;  

 ;;Standard data dictionaries on your RPMS system have been updated.

 ;;  

 ;;You are receiving this message because of the particular 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 Help Desk,

 ;;refer to patch "ACHS*3.1*14".

 ;;  

 ;;###;NOTE: This line end of text.

 ;

 ; ---------------------------------------------

 ; 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("ACHS3114",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("ACHS3114",ACHS,"DDA")) S ^XTMP("ACHS3114",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("ACHS3114",ACHS,"DDA"))_"'"),MES^XPDUTL($$RJ^XLFSTR("Set to 'Y'",69))

 . S ^DD(ACHS,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 ACHS

 S ACHS=0

 F  S ACHS=$O(^XTMP("ACHS3114",ACHS)) Q:'ACHS  D

 . S ^DD(ACHS,0,"DDA")=^XTMP("ACHS3114",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("ACHS3114")

 D MES^XPDUTL("DD AUDIT settings restored.")

 Q

 ; ---------------------------------------------

INSTALLD(ACHS) ; Determine if patch ACHS was installed, where ACHS is

 ; the name of the INSTALL.  E.g "AVA*93.2*12".

 ;

 NEW DIC,X,Y

 ;  lookup package.

 S X=$P(ACHS,"*",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(ACHS,"*",2)

 D ^DIC

 I Y<1 Q 0

 ;  lookup patch.

 S DIC=DIC_+Y_",""PAH"",",X=$P(ACHS,"*",3)

 D ^DIC

 Q $S(Y<1:0,1:1)

 ; -------------------------------------------

 ; 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

 ; Note:  above line is a loop ender.

 D BMES^XPDUTL("BEGIN Removing deleted fields from CHS data dictionaries.")

 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 data dictionaries.")

 Q

 ;

DENOPT ; check for 638 facility, and add options if 638

 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 parameter menu option added for 638 facility")

 .I $$ADD^XPDMENU("ACHSDENPARM","ACHSDENPARMREA","AREA") D MES^XPDUTL($J("",5)_"Denial parameter menu option 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 Document Generation 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 - FROM KIDS.

 ;ADD NEW OPTIONS FOR PATCH 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)_"Send approval Message to FI added to Document Generation Menu")

 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")

 D MES^XPDUTL("END updating options.")

 Q

NONREG ;EP - from 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 - From KIDS.  

 ;SETS DENIAL STATUS IF DENIAL 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 - From KIDS

 ;GETS RID OF VERSION 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

 ;Note above line ends loop

 ;

P7OPT ;EP -FROM KIDS

 ;ADD NEW OPTIONS FOR PATCH 7, ELECTRONIC SIGNATURE AND ELECTRONIC 

 ;SIGNATURE REPORTS

 D BMES^XPDUTL("Adding new options.")

 I $$ADD^XPDMENU("ACHSMENU","ACHS E-SIG MENU","EMNU") D MES^XPDUTL($J("",5)_"Electronic Signature Authorization Menu to main 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 Signature for Authorizing Official, Electronic Signature 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-from KIDS  PATCH 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.DOMAIN.NAME"_";.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-From kids PATCH 14

 N X,Y

 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.DOMAIN.NAME"_";.03////"_"D1\WEBFRS_CHS"_";.04////"_"KEVeJ9wr"_";.06////"_"-ia"_";.07////"_"B"_";.08////"_"sendto"

 D ^DIE

 K D,D0,D1,DI,DIADD,DIC,DICR,DIE,DLAYGO,DQ,DR,DINUM,DA

SSC ;ADD NAICS CODES TO SSC

 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

P4 ;EP - from KIDS.

 Q:'$G(XPDQUES("POS4"))

 D BMES^XPDUTL("BEGIN Re-index of Patient 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 Patient Name in Deferred Services.")

 Q

 ;

P5 ;EP - from KIDS

 Q:'$G(XPDQUES("POS5"))

 ;

 ; --- Atch Denial ltr edit option at 638 sites.

 S %="DENOPT^ACHS3114"

 I $$NEWCP^XPDUTL("POS5-"_%,%)

 ;

 ; --- Delete fields in CHS files marked for deletion.

 S %="DELFLD^ACHS3114"

 I $$NEWCP^XPDUTL("POS6-"_%,%)

 ;

 ; --- Atch 278 menu to Doc edit option.

 S %="M278^ACHS3114"

 I $$NEWCP^XPDUTL("POS7-"_%,%)

 ;

 ; --- Remove non-standard option auditing from CHS options. 

 S %="POS^ACHS31P0"

 I $$NEWCP^XPDUTL("POS8-"_%,%)

 Q

P6 ;EP - from KIDS

 Q:'$G(XPDQUES("POS9"))

 ;

 ; --- Atch Denial APPEAL option.

 S %="P6OPT^ACHS3114"

 I $$NEWCP^XPDUTL("POS9-"_%,%)

 ;

 ; --- Re-index non-registered patient name.

 S %="NONREG^ACHS3114"

 I $$NEWCP^XPDUTL("POS10-"_%,%)

 ;

 ; --- Set appeal status if denial reversed.

 S %="DENREV^ACHS3114"

 I $$NEWCP^XPDUTL("POS11-"_%,%)

 Q

 ;

P7 ;EP-from KIDS

 Q:'$G(XPDQUES("POS12"))

 ;

 ; --REMOVE OLD DD STUFF LEFT FROM VERSION 1.45 

 S %="V145DD^ACHS3114"

 I $$NEWCP^XPDUTL("POS12-"_%,%)

 ;

 ; ---ATTACH E SIG OPTIONS---

 S %="P7OPT^ACHS3114"

 I $$NEWCP^XPDUTL("POS13-"_%,%)

 Q

 ;

P12 ;EP-from KIDS

 Q:$$INSTALLD("ACHS*3.1*12")

 S %="TEST^ACHSPQTS"

 I $$NEWCP^XPDUTL("POS15-"_%,%)

 ;

 S %="HHS^ACHS3114"

 I $$NEWCP^XPDUTL("POS16-"_%,%)

 Q

P13 ;EP-from KIDS

 Q:$$INSTALLD("ACHS*3.1*13")

 S %="UFMS^ACHS3114"

 I $$NEWCP^XPDUTL("POS17-"_%,%)

 Q

P14 ;EP-from KIDS

 Q:$$INSTALLD("ACHS*3.1*14")

 S %="DCIS^ACHS3114"

 I $$NEWCP^XPDUTL("POS18-"_%,%)

 Q

ACHS3114  ;IHS/OIT/FCJ - ACHS 3.1 PATCH 14 ; JUL 10, 2008

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14**;JUNE 11,2001

 +2       ;3.1*14 12/7/2006;IHS/OIT/FCJ - ORIG RTN P13

 +3       ;               MOVED ENV CHECK TO ACHS31E1

 +4       ;

PRE       ;EP - From KIDS.

 +1        IF $$NEWCP^XPDUTL("PRE1","AUDS^ACHS3114")

 +2        QUIT 

 +3       ;

POST      ;EP - From KIDS.

 +1       ; ---Patches 4,5,6,7 Checks installs are done in Install Questions.

 +2       ; ---Question for 3 was removed, need "C" index for lookup of non-registered patients.

 +3        SET %="P4^ACHS3114"

 +4        IF $$NEWCP^XPDUTL("POS4-"_%,%)

 +5        SET %="P5^ACHS3114"

 +6        IF $$NEWCP^XPDUTL("POS5-"_%,%)

 +7       ;

 +8        SET %="P6^ACHS3114"

 +9        IF $$NEWCP^XPDUTL("POS9-"_%,%)

 +10      ;

 +11       SET %="P7^ACHS3114"

 +12       IF $$NEWCP^XPDUTL("POS12-"_%,%)

 +13      ;

 +14      ;PATCH 12

 +15       SET %="P12^ACHS3114"

 +16       IF $$NEWCP^XPDUTL("POS14-"_%,%)

 +17      ;       

 +18      ;PATCH 13

 +19       SET %="P13^ACHS3114"

 +20       IF $$NEWCP^XPDUTL("POS17-"_%,%)

 +21      ;

 +22      ;PATCH 14

 +23       SET %="P14^ACHS3114"

 +24       IF $$NEWCP^XPDUTL("POS18-"_%,%)

 +25      ;

 +26      ; --- Restore dd audit settings.

 +27       SET %="AUDR^ACHS3114"

 +28       IF $$NEWCP^XPDUTL("POS19-"_%,%)

 +29      ;

 +30      ; --- Send mail message of install.

 +31       SET %="MAIL^ACHS3114"

 +32       IF $$NEWCP^XPDUTL("POS20-"_%,%)

 +33      ;

 +34       QUIT 

MAIL      ;

 +1        DO BMES^XPDUTL("BEGIN Delivering MailMan message to select users.")

 +2        NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY

 +3        KILL ^TMP("ACHS3114",$JOB)

 +4        DO RSLT(" --- ACHS v 3.1 Patch 14, has been installed into this uci ---")

 +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(""ACHS3114"",$J,"

           SET XMY(1)=""

           SET XMY(DUZ)=""

 +9        FOR %="ACHSZMENU","XUMGR","XUPROG","XUPROGMODE"

               DO SINGLE(%)

 +10       DO ^XMD

 +11       KILL ^TMP("ACHS3114",$JOB)

 +12       DO MES^XPDUTL("END Delivering MailMan message to select users.")

 +13       QUIT 

 +14      ;

RSLT(%)    SET ^(0)=$GET(^TMP("ACHS3114",$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       ;

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 particular 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 Help Desk,

 +10      ;;refer to patch "ACHS*3.1*14".

 +11      ;;  

 +12      ;;###;NOTE: This line end of text.

 +13      ;

 +14      ; ---------------------------------------------

 +15      ; The global location for dictionary audit is:

 +16      ;           ^DD(FILE,0,"DDA")

 +17      ; If the valuey is "Y", dd audit is on.  Any other value, or the

 +18      ; absence of the node, means dd audit is off.

 +19      ; ---------------------------------------------

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("ACHS3114",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("ACHS3114",ACHS,"DDA"))

                       SET ^XTMP("ACHS3114",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("ACHS3114",ACHS,"DDA"))_"'")

                   DO MES^XPDUTL($$RJ^XLFSTR("Set to 'Y'",69))

 +9                SET ^DD(ACHS,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 ACHS

 +3        SET ACHS=0

 +4        FOR 

               SET ACHS=$ORDER(^XTMP("ACHS3114",ACHS))

               IF 'ACHS

                   QUIT 

               Begin DoDot:1

 +5                SET ^DD(ACHS,0,"DDA")=^XTMP("ACHS3114",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("ACHS3114")

 +9        DO MES^XPDUTL("DD AUDIT settings restored.")

 +10       QUIT 

 +11      ; ---------------------------------------------

INSTALLD(ACHS) ; Determine if patch ACHS was installed, where ACHS is

 +1       ; the name of the INSTALL.  E.g "AVA*93.2*12".

 +2       ;

 +3        NEW DIC,X,Y

 +4       ;  lookup package.

 +5        SET X=$PIECE(ACHS,"*",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(ACHS,"*",2)

 +11       DO ^DIC

 +12       IF Y<1

               QUIT 0

 +13      ;  lookup patch.

 +14       SET DIC=DIC_+Y_",""PAH"","

           SET X=$PIECE(ACHS,"*",3)

 +15       DO ^DIC

 +16       QUIT $SELECT(Y<1:0,1:1)

 +17      ; -------------------------------------------

 +18      ; Fields to be deleted.

 +19      ;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      ; Note:  above line is a loop ender.

 +16       DO BMES^XPDUTL("BEGIN Removing deleted fields from CHS data dictionaries.")

 +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 data dictionaries.")

 +24       QUIT 

 +25      ;

DENOPT    ; check for 638 facility, and add options if 638

 +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 parameter menu option added for 638 facility")

 +6                    IF $$ADD^XPDMENU("ACHSDENPARM","ACHSDENPARMREA","AREA")

                           DO MES^XPDUTL($JUSTIFY("",5)_"Denial parameter menu option 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 Document Generation 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 - FROM KIDS.

 +1       ;ADD NEW OPTIONS FOR PATCH 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)_"Send approval Message to FI added to Document Generation Menu")

 +4        IF $$ADD^XPDMENU("ACHS DEFDEN MENU","ACHS DEN APPEAL MENU","APP")

               DO MES^XPDUTL($JUSTIFY("",5)_"Denial Appeal menu option added to CHS Denial/Deferred ServciesMenu")

 +5        DO MES^XPDUTL("END updating options.")

 +6        QUIT 

NONREG    ;EP - from 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 - From KIDS.  

 +1       ;SETS DENIAL STATUS IF DENIAL 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 - From KIDS

 +1       ;GETS RID OF VERSION 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      ;Note above line ends loop

 +16      ;

P7OPT     ;EP -FROM KIDS

 +1       ;ADD NEW OPTIONS FOR PATCH 7, ELECTRONIC SIGNATURE AND ELECTRONIC 

 +2       ;SIGNATURE REPORTS

 +3        DO BMES^XPDUTL("Adding new options.")

 +4        IF $$ADD^XPDMENU("ACHSMENU","ACHS E-SIG MENU","EMNU")

               DO MES^XPDUTL($JUSTIFY("",5)_"Electronic Signature Authorization Menu to main CHS Menu")

 +5        IF $$ADD^XPDMENU("ACHS E-SIG MENU","ACHS E-SIG AUTHORIZING OFC.","SIGA")

 +6        IF $$ADD^XPDMENU("ACHS E-SIG MENU","ACHS E-SIG ORDERING OFC.","SIGO")

               DO MES^XPDUTL($JUSTIFY("",5)_"Electronic Signature for Authorizing Official, Electronic Signature for Ordering Official")

 +7        IF $$ADD^XPDMENU("ACHSREPORTS","ACHS E-SIG REPORTS","ERPT")

 +8        IF $$ADD^XPDMENU("ACHS E-SIG REPORTS","ACHS E-SIG APPROVED REPORT","ESAP")