ACHSTX ; IHS/ITSC/PMF - EXPORT DATA (1/9) ;JUL 10, 2008
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,7,13,14,16,21**;JUN 11,2001;Build 43
;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Allow AlphaNumeric ACN.
;IHS/SET/JVK ACHS*3.1*7 11/6/03 - Do not allow export unless ESig Que is empty
;IHS/OIT/FCJ ACHS*3.1*13 7/16/07 Added test for UFMS export and record counts for export
;IHS/OIT/FCJ ACHS*3.1*14 11/5/07 Added RE-Export process for UFMS
;
;perform test version instead?
;S PMF="" F S PMF=$O(^ACHS("Test Version",PMF)) Q:PMF="" I $G(^(PMF))["ACHSTX" S PMF=^(PMF) Q;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;I PMF'="",$P(PMF,U,3) S PMF=$P(PMF,U,2) D @PMF K PMF Q;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;K PMF;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;
;
I $$PARM^ACHS(0,8)="Y" Q:$$STATCHK
;
K DIR ;ACHS*3.1*16 IHS.OIT.FCJ ADDED LINE BECAUSE OF VAR BEING SET IN PAT REG AND NOT KILLED
I '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"")","+") W *7,!! W:$$DIR^XBDIR("E","CHS DATA ENTRY IN PROGRESS -- JOB CANCELLED - <RETURN> TO CONTINUE") "" G KILL^ACHSTX8
;ITSC/SET/JVK ACHS*3.1*7 11/6/03
I 'ACHSREEX,$D(^ACHSF("EQ",DUZ(2))) W *7,!! W:$$DIR^XBDIR("E","CHS DOCUMENTS REQUIRE E-SIG -- JOB CANCELLED - <RETURN> TO CONTINUE") "" G KILL^ACHSTX8
;ACHS*3.1*14 IHS/OIT/FCJ ADDED NXT 2 LINES FOR TEST OF RE-EXPORT; COMMENTED OUT NXT 2 LINES FOR NEW FILE TYPE-ACHS*3.1*21
;I $D(^ACHSDATA(0)),$P(^ACHSDATA(0),U,3)=DT,$P(^ACHSDATA(0),U)=$P(^AUTTLOC(DUZ(2),0),U,10) W !!?5,"A RE-EXPORT HAS ALREADY BEEN RAN TODAY, YOU WILL WRITE OVER",!?5,"THE FILE IF YOU CONTINUE."
;S DIR(0)="E" D ^DIR G KILL^ACHSTX8:$D(DUOUT)!$D(DTOUT)
;
D ^ACHSVAR
S ACHSRCT=0
;ACHS*3.1*13 IHS/OIT/FCJ chg 7 to 8 in nxt line to set rec count for UFMS
F ACHS=2:1:8 S ACHSRTYP(ACHS)=0
L2 ;
W !!,"Export data will be made for ",$$LOC^ACHS
G END:'$$DIR^XBDIR("Y","Is this Correct (Y/N) ","YES","","Export data will be made for "_$$LOC^ACHS,"",2)
G END:$D(DUOUT)!$D(DTOUT)
;ACHS*3.1*21 COMMENTED OUT NXT 3 LINES
;I $$EXFILE D I '$$DIR^XBDIR("Y","Continue","N","","","^D HELP^ACHS(""FILEHELP"",""ACHSTX"")",1) G END
;. W !!,*7
;. D HELP^ACHS("FILEHELP","ACHSTX")
;.Q
K DIC,X,Y
S DIC="^ACHSTXST("_DUZ(2)_",1,",DIC(0)="Z",X=DT
D ^DIC
K DIC,X
I Y>0,$P(Y(0),U,10)="N" G ^ACHSTXTT
I 'ACHSREEX,$D(^ACHSTXST("C",DT,DUZ(2))) G TXFEF^ACHSTX8
S ACHSARCO=$P(^ACHSF(DUZ(2),0),U,11)
;I +ACHSARCO<1!($L(ACHSARCO)'=3) U IO(0) W *7,!!,"MISSING AREA CONTRACTING NUMBER - JOB CANCELLED" G ERROR;IHS/SET/GTH ACHS*3.1*5 12/06/2002
I '(ACHSARCO?3UN) U IO(0) W *7,!!,"Area Contracting Number is not 3 Upper-case Alpha-Numerics",!,"JOB CANCELLED" G ERROR ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
U IO(0)
S ACHSCRTN=""
L3 ;
S ACHSMDAT=$$DTAO
G END:$D(DUOUT)!$D(DTOUT)
;
;03/01/02 pmf clean up vars used to open and close a slave printer
;K %ZIS
K %ZIS,ACHSPPC,ACHSPPO
;
S %ZIS("A")="ENTER OUTPUT REPORT DEVICE # ",%ZIS="P"
W !
D ^%ZIS
G END:POP
I $D(IO("S")) D SLV^ACHSFU
S ACHSIO=IO,ACHSION=ION
D ^%ZISC,HOME^%ZIS
;
;ACHS*3.1*13 IHS/OIT/FCJ ADDED NXT 2 LINES; TEST FOR UFMS START DATE
S ACHSUSDT=$P(^ACHSF(DUZ(2),0),U,13)
;ACHS*3.1*14 IHS/OIT/FCJ ADDED RE-EXPORT PROCESS FOR UFMS MV G AFTER TEST FOR ACHSREEX
;S ACHSTXTY=$S(ACHSUSDT="":"S",ACHSUSDT>DT:"S",1:"U") G:ACHSTXTY="U" ^ACHSTXF
S ACHSTXTY=$S(ACHSUSDT="":"S",ACHSUSDT>DT:"S",1:"U")
I ACHSREEX D ^ACHSTXAR Q
G:ACHSTXTY="U" ^ACHSTXF
D ^ACHSTX2
Q
;
;
;
KILLGLBS ;EP - Kill unsubscripted work globals.
; ^ACHSDATA( - DHR (REC #2) All record types are set in this global to be sent to Area
; ^ACHSTXPT( - Holds Patients to be exported. (Rec # 3)
; ^ACHSTXVN( - Holds Vendor IENs to be exported. (Rec # 4)
; ^ACHSTXOB( - Holds Document/Transaction to be exported. (Rec # 5)
; ^ACHSTXPD( - Holds Paid Doc info to be exported to Area Office. (Rec # 6)
; ^ACHSTXPG( - Holds Docs with statistical info to be exported to Data Center. (Rec # 7)
;
N ACHS
F ACHS="^ACHSDATA","^ACHSTXPT","^ACHSTXVN","^ACHSTXOB","^ACHSTXPD","^ACHSTXPG" D
. W !,"Resetting ",ACHS,"(0)"
. ;2/25/02 pmf changes for cache
. ;I $$KILLOK^ZIBGCHAR($P(ACHS,U,2)) W !,$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($P(ACHS,U,2)))
. ;K @ACHS
. S @(ACHS_"(0)")=""
. S ACHSG=ACHS_"(0)" F S ACHSG=$Q(@ACHSG) Q:ACHSG="" K @ACHSG
. Q
K ACHSG
Q
;
DTAO() ;EP - Prompt for date sent to Area Office.
Q $$DIR^XBDIR("D^"_DT_":"_$$HTFM^XLFDT($H+5),"ENTER DATE SENT TO AREA OFFICE ","T")
;
ERROR ;EP.
X:$D(ACHSPCC) ACHSPPC
U IO(0)
W !!,*7,*7,*7,"AN ERROR HAS OCCURRED DURING EXPORT PLEASE NOTIFY AREA OFFICE "
D ^%ZISC
G JOBABEND^ACHSTX8
;
END ;
W !!?10,"JOB TERMINATED BY OPERATOR"
G JOBABEND^ACHSTX8
;
STATCHK() ; Check 638 stat data prior to export.
D HELP^ACHSTX7X
I $$DIR^XBDIR("Y","Run pre-export data check first","YES","","","^D HELP^ACHSTX7X",2) D ^ACHSTX7X Q 1
Q 0
;
EXFILE() ; Does export file exist?
NEW X,Y,Z
S Y=$$ASF^ACHS(DUZ(2))
I $$OS^ACHS=2 S Y=$E(Y,3,6)
S Y="ACHS"_Y_"."_$$JDT^ACHS(DT)
I $$LIST^%ZISH($$EX^ACHS,Y,.X)
S Z=""
F S Z=$O(X(Z)) Q:'Z I X(Z)=Y Q
Q $S('Z:0,1:1)
;
FILEHELP ;EP - ?? help text, from ACHS via DIR.
;;
;; *** AN EXPORT FILE FOR TODAY ALREADY EXISTS ***
;;
;;An export file already exists in your export directory for today.
;;You will overwrite the file if you continue. If the file was
;;correctly generated, the data in the file will be lost. If you
;;are certain that the data in the file was incorrectly generated,
;;then proceed, forewarned.
;;
;;###
ACHSTX ; IHS/ITSC/PMF - EXPORT DATA (1/9) ;JUL 10, 2008
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,7,13,14,16,21**;JUN 11,2001;Build 43
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Allow AlphaNumeric ACN.
+3 ;IHS/SET/JVK ACHS*3.1*7 11/6/03 - Do not allow export unless ESig Que is empty
+4 ;IHS/OIT/FCJ ACHS*3.1*13 7/16/07 Added test for UFMS export and record counts for export
+5 ;IHS/OIT/FCJ ACHS*3.1*14 11/5/07 Added RE-Export process for UFMS
+6 ;
+7 ;perform test version instead?
+8 ;S PMF="" F S PMF=$O(^ACHS("Test Version",PMF)) Q:PMF="" I $G(^(PMF))["ACHSTX" S PMF=^(PMF) Q;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+9 ;I PMF'="",$P(PMF,U,3) S PMF=$P(PMF,U,2) D @PMF K PMF Q;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+10 ;K PMF;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+11 ;
+12 ;
+13 IF $$PARM^ACHS(0,8)="Y"
IF $$STATCHK
QUIT
+14 ;
+15 ;ACHS*3.1*16 IHS.OIT.FCJ ADDED LINE BECAUSE OF VAR BEING SET IN PAT REG AND NOT KILLED
KILL DIR
+16 IF '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"")","+")
WRITE *7,!!
IF $$DIR^XBDIR("E","CHS DATA ENTRY IN PROGRESS -- JOB CANCELLED - <RETURN> TO CONTINUE")
WRITE ""
GOTO KILL^ACHSTX8
+17 ;ITSC/SET/JVK ACHS*3.1*7 11/6/03
+18 IF 'ACHSREEX
IF $DATA(^ACHSF("EQ",DUZ(2)))
WRITE *7,!!
IF $$DIR^XBDIR("E","CHS DOCUMENTS REQUIRE E-SIG -- JOB CANCELLED - <RETURN> TO CONTINUE")
WRITE ""
GOTO KILL^ACHSTX8
+19 ;ACHS*3.1*14 IHS/OIT/FCJ ADDED NXT 2 LINES FOR TEST OF RE-EXPORT; COMMENTED OUT NXT 2 LINES FOR NEW FILE TYPE-ACHS*3.1*21
+20 ;I $D(^ACHSDATA(0)),$P(^ACHSDATA(0),U,3)=DT,$P(^ACHSDATA(0),U)=$P(^AUTTLOC(DUZ(2),0),U,10) W !!?5,"A RE-EXPORT HAS ALREADY BEEN RAN TODAY, YOU WILL WRITE OVER",!?5,"THE FILE IF YOU CONTINUE."
+21 ;S DIR(0)="E" D ^DIR G KILL^ACHSTX8:$D(DUOUT)!$D(DTOUT)
+22 ;
+23 DO ^ACHSVAR
+24 SET ACHSRCT=0
+25 ;ACHS*3.1*13 IHS/OIT/FCJ chg 7 to 8 in nxt line to set rec count for UFMS
+26 FOR ACHS=2:1:8
SET ACHSRTYP(ACHS)=0
L2 ;
+1 WRITE !!,"Export data will be made for ",$$LOC^ACHS
+2 IF '$$DIR^XBDIR("Y","Is this Correct (Y/N) ","YES","","Export data will be made for "_$$LOC^ACHS,"",2)
GOTO END
+3 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO END
+4 ;ACHS*3.1*21 COMMENTED OUT NXT 3 LINES
+5 ;I $$EXFILE D I '$$DIR^XBDIR("Y","Continue","N","","","^D HELP^ACHS(""FILEHELP"",""ACHSTX"")",1) G END
+6 ;. W !!,*7
+7 ;. D HELP^ACHS("FILEHELP","ACHSTX")
+8 ;.Q
+9 KILL DIC,X,Y
+10 SET DIC="^ACHSTXST("_DUZ(2)_",1,"
SET DIC(0)="Z"
SET X=DT
+11 DO ^DIC
+12 KILL DIC,X
+13 IF Y>0
IF $PIECE(Y(0),U,10)="N"
GOTO ^ACHSTXTT
+14 IF 'ACHSREEX
IF $DATA(^ACHSTXST("C",DT,DUZ(2)))
GOTO TXFEF^ACHSTX8
+15 SET ACHSARCO=$PIECE(^ACHSF(DUZ(2),0),U,11)
+16 ;I +ACHSARCO<1!($L(ACHSARCO)'=3) U IO(0) W *7,!!,"MISSING AREA CONTRACTING NUMBER - JOB CANCELLED" G ERROR;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+17 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
IF '(ACHSARCO?3UN)
USE IO(0)
WRITE *7,!!,"Area Contracting Number is not 3 Upper-case Alpha-Numerics",!,"JOB CANCELLED"
GOTO ERROR
+18 USE IO(0)
+19 SET ACHSCRTN=""
L3 ;
+1 SET ACHSMDAT=$$DTAO
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO END
+3 ;
+4 ;03/01/02 pmf clean up vars used to open and close a slave printer
+5 ;K %ZIS
+6 KILL %ZIS,ACHSPPC,ACHSPPO
+7 ;
+8 SET %ZIS("A")="ENTER OUTPUT REPORT DEVICE # "
SET %ZIS="P"
+9 WRITE !
+10 DO ^%ZIS
+11 IF POP
GOTO END
+12 IF $DATA(IO("S"))
DO SLV^ACHSFU
+13 SET ACHSIO=IO
SET ACHSION=ION
+14 DO ^%ZISC
DO HOME^%ZIS
+15 ;
+16 ;ACHS*3.1*13 IHS/OIT/FCJ ADDED NXT 2 LINES; TEST FOR UFMS START DATE
+17 SET ACHSUSDT=$PIECE(^ACHSF(DUZ(2),0),U,13)
+18 ;ACHS*3.1*14 IHS/OIT/FCJ ADDED RE-EXPORT PROCESS FOR UFMS MV G AFTER TEST FOR ACHSREEX
+19 ;S ACHSTXTY=$S(ACHSUSDT="":"S",ACHSUSDT>DT:"S",1:"U") G:ACHSTXTY="U" ^ACHSTXF
+20 SET ACHSTXTY=$SELECT(ACHSUSDT="":"S",ACHSUSDT>DT:"S",1:"U")
+21 IF ACHSREEX
DO ^ACHSTXAR
QUIT
+22 IF ACHSTXTY="U"
GOTO ^ACHSTXF
+23 DO ^ACHSTX2
+24 QUIT
+25 ;
+26 ;
+27 ;
KILLGLBS ;EP - Kill unsubscripted work globals.
+1 ; ^ACHSDATA( - DHR (REC #2) All record types are set in this global to be sent to Area
+2 ; ^ACHSTXPT( - Holds Patients to be exported. (Rec # 3)
+3 ; ^ACHSTXVN( - Holds Vendor IENs to be exported. (Rec # 4)
+4 ; ^ACHSTXOB( - Holds Document/Transaction to be exported. (Rec # 5)
+5 ; ^ACHSTXPD( - Holds Paid Doc info to be exported to Area Office. (Rec # 6)
+6 ; ^ACHSTXPG( - Holds Docs with statistical info to be exported to Data Center. (Rec # 7)
+7 ;
+8 NEW ACHS
+9 FOR ACHS="^ACHSDATA","^ACHSTXPT","^ACHSTXVN","^ACHSTXOB","^ACHSTXPD","^ACHSTXPG"
Begin DoDot:1
+10 WRITE !,"Resetting ",ACHS,"(0)"
+11 ;2/25/02 pmf changes for cache
+12 ;I $$KILLOK^ZIBGCHAR($P(ACHS,U,2)) W !,$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($P(ACHS,U,2)))
+13 ;K @ACHS
+14 SET @(ACHS_"(0)")=""
+15 SET ACHSG=ACHS_"(0)"
FOR
SET ACHSG=$QUERY(@ACHSG)
IF ACHSG=""
QUIT
KILL @ACHSG
+16 QUIT
End DoDot:1
+17 KILL ACHSG
+18 QUIT
+19 ;
DTAO() ;EP - Prompt for date sent to Area Office.
+1 QUIT $$DIR^XBDIR("D^"_DT_":"_$$HTFM^XLFDT($HOROLOG+5),"ENTER DATE SENT TO AREA OFFICE ","T")
+2 ;
ERROR ;EP.
+1 IF $DATA(ACHSPCC)
XECUTE ACHSPPC
+2 USE IO(0)
+3 WRITE !!,*7,*7,*7,"AN ERROR HAS OCCURRED DURING EXPORT PLEASE NOTIFY AREA OFFICE "
+4 DO ^%ZISC
+5 GOTO JOBABEND^ACHSTX8
+6 ;
END ;
+1 WRITE !!?10,"JOB TERMINATED BY OPERATOR"
+2 GOTO JOBABEND^ACHSTX8
+3 ;
STATCHK() ; Check 638 stat data prior to export.
+1 DO HELP^ACHSTX7X
+2 IF $$DIR^XBDIR("Y","Run pre-export data check first","YES","","","^D HELP^ACHSTX7X",2)
DO ^ACHSTX7X
QUIT 1
+3 QUIT 0
+4 ;
EXFILE() ; Does export file exist?
+1 NEW X,Y,Z
+2 SET Y=$$ASF^ACHS(DUZ(2))
+3 IF $$OS^ACHS=2
SET Y=$EXTRACT(Y,3,6)
+4 SET Y="ACHS"_Y_"."_$$JDT^ACHS(DT)
+5 IF $$LIST^%ZISH($$EX^ACHS,Y,.X)
+6 SET Z=""
+7 FOR
SET Z=$ORDER(X(Z))
IF 'Z
QUIT
IF X(Z)=Y
QUIT
+8 QUIT $SELECT('Z:0,1:1)
+9 ;
FILEHELP ;EP - ?? help text, from ACHS via DIR.
+1 ;;
+2 ;; *** AN EXPORT FILE FOR TODAY ALREADY EXISTS ***
+3 ;;
+4 ;;An export file already exists in your export directory for today.
+5 ;;You will overwrite the file if you continue. If the file was
+6 ;;correctly generated, the data in the file will be lost. If you
+7 ;;are certain that the data in the file was incorrectly generated,
+8 ;;then proceed, forewarned.
+9 ;;
+10 ;;###
