AG6P17B ;IHS/ASDST/GTH - Patient Registration 6.0 Patch 17 CONT. ;
;;7.0;IHS PATIENT REGISTRATION;;MAR 28, 2003
;
; IHS/SET/GTH AG*6*17 10/01/2002
;
P17 ;EP -- Update EXIT ACTION of AGMENU to call AG^AGHL7.
;;D AG^AGHL7,PHDR^AG,KILL^AG I $D(AGSADUZ2) S DUZ(2)=AGSADUZ2 K AGSADUZ2
;
NEW DA,DIE,DR
S DA=""
F S DA=$O(^DIC(19,"B","AGMENU",DA)) Q:DA="" D
. Q:^DIC(19,DA,15)=$P($T(P17+1),";",3)
. S DIE="^DIC(19,",DR="15///"_$P($T(P17+1),";",3)
. D ^DIE
.Q
Q
;
INDXC ;EP - Index "C" x-ref on Elig. Upload log file.
D BMES^XPDUTL("Indexing new 'C' x-ref on ELIGIBILITY UPLOAD LOG file...")
NEW DIK
S DIK="^AGELUPLG(",DIK(1)=".03^C"
D ENALL^DIK
D MES^XPDUTL("Index of 'C' complete.")
Q
;
COVIT ;EP - Check MCD Coverage Types.
D BMES^XPDUTL("Checking Medicaid Coverage Types.")
;
KILL ^TMP("AG6P17B",$J)
;
D RSLT("The following Patients have bad Coverage Type values in their")
D RSLT("Medicaid Eligibility information. This was caused by a bug")
D RSLT("present for many years. The value of the Coverage Type(s) can")
D RSLT("be corrected by editing the Patient's Medicaid information on")
D RSLT("Patient Registration, Page 5."),RSLT(" ")
D RSLT(" ( To re-run the report: D COVIT^AG6P17B ) .")
D RSLT($J("PATIENT",20)_$J("HRN",8)_" MEDICAID #"_" ELIG. DATE COVERAGE TYPE")
D RSLT("-------------------- ------ ---------- ------------ -------------")
;
NEW AGD2,AGD2,AGD1,AGIT,DFN
;
S AGIT=$P(^DD(9000004.11,.03,0),U,5,99)
F AGD2=0:0 S AGD2=$O(^AUPNMCD(AGD2)) Q:'AGD2 D
. F AGD1=0:0 S AGD1=$O(^AUPNMCD(AGD2,11,AGD1)) Q:'AGD1 D
.. S X=$P(^AUPNMCD(AGD2,11,AGD1,0),U,3)
.. Q:'$L(X)
.. X AGIT
.. Q:$D(X)
.. S DFN=$P(^AUPNMCD(AGD2,0),U)
.. D RSLT($J($P(^DPT(DFN,0),U,1),20)_$J($P($G(^AUPNPAT(DFN,41,DUZ(2),0),"??"),U,2),8)_$J($P(^AUPNMCD(AGD2,0),U,3),12)_" "_$$FMTE^XLFDT(AGD1)_" '"_$P(^AUPNMCD(AGD2,11,AGD1,0),U,3)_"'")
..Q
.Q
;
D MES^XPDUTL("Sending e-mail to local data entry person(s).")
;
NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
S XMSUB="** Report Bad Medicaid Coverage Types **",XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AG6P17B"",$J,",XMY(1)="",XMY(DUZ)=""
F %="AGZMENU","ABMDZ ELIGIBILITY EDIT","XUMGR","XUPROG","XUPROGMODE" D SINGLE^AG6P17A(%)
D ^XMD
KILL ^TMP("AG6P17B",$J)
;
D MES^XPDUTL("...Done.")
Q
;
RSLT(%) S ^(0)=$G(^TMP("AG6P17B",$J,0))+1,^(^(0))=% D MES^XPDUTL(%)
Q
;
AGTX ;EP - Remove options from AGTX menu.
D BMES^XPDUTL("Removing ""AG TX CONFIG"" and ""AGTXALL"" option from export menu ""AGTX"".")
D MES^XPDUTL("These are the ""CONF"" and ""ALL"" options used for the NPIRS re-load.")
NEW AGOPT,DIK,DA,X
S DA(1)=$O(^DIC(19,"B","AGTX",0))
I 'DA(1) D MES^XPDUTL("...Option 'AGTX' not found in file 19: ERROR.")
I DA(1) F AGOPT="AG TX CONFIG","AGTXALL" D
. S DA=$O(^DIC(19,"B",AGOPT,0))
. I 'DA(1) D MES^XPDUTL("...Option '"_AGOPT_"' not found in file 19: ERROR.") Q
. S DA=$O(^DIC(19,DA(1),10,"B",DA,0))
. I 'DA D MES^XPDUTL("...Option '"_AGOPT_"' wasn't atch'd to 'AGTX'. That's OK.") Q
. S DIK="^DIC(19,DA(1),10,"
. D ^DIK
. D MES^XPDUTL("Option '"_AGOPT_"' removed from 'AGTX'.")
.Q
D MES^XPDUTL("...Done.")
Q
;
DELR ;EP - Delete unneeded AGTXX* and AGTXZ* routines.
D BMES^XPDUTL("Deleting unneeded AGTXX* and AGTXZ* routines.")
KILL ^TMP("AG6P17B",$J)
I $$RSEL^ZIBRSEL("AGTXX*","^TMP(""AG6P17B"","_$J_",") D DEL
I $$RSEL^ZIBRSEL("AGTXZ*","^TMP(""AG6P17B"","_$J_",") D DEL
D MES^XPDUTL("...Done.")
Q
DEL ;
NEW X
S X=""
F S X=$O(^TMP("AG6P17B",$J,X)) Q:X="" X ^%ZOSF("DEL") I $G(XPDA) D MES^XPDUTL(X_$E("...........",1,11-$L(X))_"<poof'd>")
KILL ^TMP("AG6P17B",$J)
Q
;
EV ;EP - Process 270/271 components.
D BMES^XPDUTL("Processing 270/271 fields/components.")
D MES^XPDUTL("Updating Eligibility Checking Period.")
NEW DR
I $G(XPDQUES("POS1")) D I 1
. NEW DA,DIC,DIE,DR
. S DA=DUZ(2),DIE="^AGFAC(",DR="35///"_XPDQUES("POS1")
. D ^DIE
. D MES^XPDUTL("...parameter updated.")
.Q
E D MES^XPDUTL("***error: Could not find parameter in post-install.")
;
D MES^XPDUTL("Attaching the '270/271 processing' menu to the 'Eligibility' menu.")
I $$ADD^XPDMENU("AG TM ELIGIBILITY","AGEV MENU","ECHK") D MES^XPDUTL("....successfully atch'd."),MES^XPDUTL("NOTE: Security Key *NOT* allocated.") I 1
E D BMES^XPDUTL("....Attachment *FAILED*.")
D MES^XPDUTL("End Processing 270/271 fields/components.")
Q
;
AG6P17B ;IHS/ASDST/GTH - Patient Registration 6.0 Patch 17 CONT. ;
+1 ;;7.0;IHS PATIENT REGISTRATION;;MAR 28, 2003
+2 ;
+3 ; IHS/SET/GTH AG*6*17 10/01/2002
+4 ;
P17 ;EP -- Update EXIT ACTION of AGMENU to call AG^AGHL7.
+1 ;;D AG^AGHL7,PHDR^AG,KILL^AG I $D(AGSADUZ2) S DUZ(2)=AGSADUZ2 K AGSADUZ2
+2 ;
+3 NEW DA,DIE,DR
+4 SET DA=""
+5 FOR
SET DA=$ORDER(^DIC(19,"B","AGMENU",DA))
IF DA=""
QUIT
Begin DoDot:1
+6 IF ^DIC(19,DA,15)=$PIECE($TEXT(P17+1),";",3)
QUIT
+7 SET DIE="^DIC(19,"
SET DR="15///"_$PIECE($TEXT(P17+1),";",3)
+8 DO ^DIE
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
INDXC ;EP - Index "C" x-ref on Elig. Upload log file.
+1 DO BMES^XPDUTL("Indexing new 'C' x-ref on ELIGIBILITY UPLOAD LOG file...")
+2 NEW DIK
+3 SET DIK="^AGELUPLG("
SET DIK(1)=".03^C"
+4 DO ENALL^DIK
+5 DO MES^XPDUTL("Index of 'C' complete.")
+6 QUIT
+7 ;
COVIT ;EP - Check MCD Coverage Types.
+1 DO BMES^XPDUTL("Checking Medicaid Coverage Types.")
+2 ;
+3 KILL ^TMP("AG6P17B",$JOB)
+4 ;
+5 DO RSLT("The following Patients have bad Coverage Type values in their")
+6 DO RSLT("Medicaid Eligibility information. This was caused by a bug")
+7 DO RSLT("present for many years. The value of the Coverage Type(s) can")
+8 DO RSLT("be corrected by editing the Patient's Medicaid information on")
+9 DO RSLT("Patient Registration, Page 5.")
DO RSLT(" ")
+10 DO RSLT(" ( To re-run the report: D COVIT^AG6P17B ) .")
+11 DO RSLT($JUSTIFY("PATIENT",20)_$JUSTIFY("HRN",8)_" MEDICAID #"_" ELIG. DATE COVERAGE TYPE")
+12 DO RSLT("-------------------- ------ ---------- ------------ -------------")
+13 ;
+14 NEW AGD2,AGD2,AGD1,AGIT,DFN
+15 ;
+16 SET AGIT=$PIECE(^DD(9000004.11,.03,0),U,5,99)
+17 FOR AGD2=0:0
SET AGD2=$ORDER(^AUPNMCD(AGD2))
IF 'AGD2
QUIT
Begin DoDot:1
+18 FOR AGD1=0:0
SET AGD1=$ORDER(^AUPNMCD(AGD2,11,AGD1))
IF 'AGD1
QUIT
Begin DoDot:2
+19 SET X=$PIECE(^AUPNMCD(AGD2,11,AGD1,0),U,3)
+20 IF '$LENGTH(X)
QUIT
+21 XECUTE AGIT
+22 IF $DATA(X)
QUIT
+23 SET DFN=$PIECE(^AUPNMCD(AGD2,0),U)
+24 DO RSLT($JUSTIFY($PIECE(^DPT(DFN,0),U,1),20)_$JUSTIFY($PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0),"??"),U,2),8)_$JUSTIFY($PIECE(^AUPNMCD(AGD2,0),U,3),12)_" "_$$FMTE^XLFDT(AGD1)_" '"_$PIECE(^AUPNMCD(AGD2,11,AGD1,0),U,3)_"'")
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
+27 ;
+28 DO MES^XPDUTL("Sending e-mail to local data entry person(s).")
+29 ;
+30 NEW DIFROM,XMSUB,XMDUZ,XMTEXT,XMY
+31 SET XMSUB="** Report Bad Medicaid Coverage Types **"
SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
SET XMTEXT="^TMP(""AG6P17B"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+32 FOR %="AGZMENU","ABMDZ ELIGIBILITY EDIT","XUMGR","XUPROG","XUPROGMODE"
DO SINGLE^AG6P17A(%)
+33 DO ^XMD
+34 KILL ^TMP("AG6P17B",$JOB)
+35 ;
+36 DO MES^XPDUTL("...Done.")
+37 QUIT
+38 ;
RSLT(%) SET ^(0)=$GET(^TMP("AG6P17B",$JOB,0))+1
SET ^(^(0))=%
DO MES^XPDUTL(%)
+1 QUIT
+2 ;
AGTX ;EP - Remove options from AGTX menu.
+1 DO BMES^XPDUTL("Removing ""AG TX CONFIG"" and ""AGTXALL"" option from export menu ""AGTX"".")
+2 DO MES^XPDUTL("These are the ""CONF"" and ""ALL"" options used for the NPIRS re-load.")
+3 NEW AGOPT,DIK,DA,X
+4 SET DA(1)=$ORDER(^DIC(19,"B","AGTX",0))
+5 IF 'DA(1)
DO MES^XPDUTL("...Option 'AGTX' not found in file 19: ERROR.")
+6 IF DA(1)
FOR AGOPT="AG TX CONFIG","AGTXALL"
Begin DoDot:1
+7 SET DA=$ORDER(^DIC(19,"B",AGOPT,0))
+8 IF 'DA(1)
DO MES^XPDUTL("...Option '"_AGOPT_"' not found in file 19: ERROR.")
QUIT
+9 SET DA=$ORDER(^DIC(19,DA(1),10,"B",DA,0))
+10 IF 'DA
DO MES^XPDUTL("...Option '"_AGOPT_"' wasn't atch'd to 'AGTX'. That's OK.")
QUIT
+11 SET DIK="^DIC(19,DA(1),10,"
+12 DO ^DIK
+13 DO MES^XPDUTL("Option '"_AGOPT_"' removed from 'AGTX'.")
+14 QUIT
End DoDot:1
+15 DO MES^XPDUTL("...Done.")
+16 QUIT
+17 ;
DELR ;EP - Delete unneeded AGTXX* and AGTXZ* routines.
+1 DO BMES^XPDUTL("Deleting unneeded AGTXX* and AGTXZ* routines.")
+2 KILL ^TMP("AG6P17B",$JOB)
+3 IF $$RSEL^ZIBRSEL("AGTXX*","^TMP(""AG6P17B"","_$JOB_",")
DO DEL
+4 IF $$RSEL^ZIBRSEL("AGTXZ*","^TMP(""AG6P17B"","_$JOB_",")
DO DEL
+5 DO MES^XPDUTL("...Done.")
+6 QUIT
DEL ;
+1 NEW X
+2 SET X=""
+3 FOR
SET X=$ORDER(^TMP("AG6P17B",$JOB,X))
IF X=""
QUIT
XECUTE ^%ZOSF("DEL")
IF $GET(XPDA)
DO MES^XPDUTL(X_$EXTRACT("...........",1,11-$LENGTH(X))_"<poof'd>")
+4 KILL ^TMP("AG6P17B",$JOB)
+5 QUIT
+6 ;
EV ;EP - Process 270/271 components.
+1 DO BMES^XPDUTL("Processing 270/271 fields/components.")
+2 DO MES^XPDUTL("Updating Eligibility Checking Period.")
+3 NEW DR
+4 IF $GET(XPDQUES("POS1"))
Begin DoDot:1
+5 NEW DA,DIC,DIE,DR
+6 SET DA=DUZ(2)
SET DIE="^AGFAC("
SET DR="35///"_XPDQUES("POS1")
+7 DO ^DIE
+8 DO MES^XPDUTL("...parameter updated.")
+9 QUIT
End DoDot:1
IF 1
+10 IF '$TEST
DO MES^XPDUTL("***error: Could not find parameter in post-install.")
+11 ;
+12 DO MES^XPDUTL("Attaching the '270/271 processing' menu to the 'Eligibility' menu.")
+13 IF $$ADD^XPDMENU("AG TM ELIGIBILITY","AGEV MENU","ECHK")
DO MES^XPDUTL("....successfully atch'd.")
DO MES^XPDUTL("NOTE: Security Key *NOT* allocated.")
IF 1
+14 IF '$TEST
DO BMES^XPDUTL("....Attachment *FAILED*.")
+15 DO MES^XPDUTL("End Processing 270/271 fields/components.")
+16 QUIT
+17 ;
