ACHSTXP ; IHS/ITSC/FCJ - 4 YR. EXPORT STAT DATA ; [ 11/09/2004 3:31 PM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**11**;June 11,2001
;IHS/ITSC/FCJ ACHS*3.1*11 9.17.04 NEW ROUTINE FOR EXPORT OF DATA FR
; OCT 1,2000 THRU SEPT 30, 2004 ORIGINAL RTN ACHSTX
;
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
D ^ACHSVAR
S ACHSRCT=0,ACHSREEX=0
L2 ;
W !!,"Export data from October 1, 2000 thru September 30,2004 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)
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
;NOTE SHOULD NOT STORE THE FOUR YEAR EXPORT
;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
S ACHSARCO=$P(^ACHSF(DUZ(2),0),U,11)
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)
;
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
;
D ^ACHSTXP2
Q
;
;
KILLGLBS ;EP - Kill unsubscripted work globals.
; ^ACHSDATA( - DHR (REC #2)
; ^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
;
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)
;
ACHSTXP ; IHS/ITSC/FCJ - 4 YR. EXPORT STAT DATA ; [ 11/09/2004 3:31 PM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**11**;June 11,2001
+2 ;IHS/ITSC/FCJ ACHS*3.1*11 9.17.04 NEW ROUTINE FOR EXPORT OF DATA FR
+3 ; OCT 1,2000 THRU SEPT 30, 2004 ORIGINAL RTN ACHSTX
+4 ;
+5 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
+6 DO ^ACHSVAR
+7 SET ACHSRCT=0
SET ACHSREEX=0
L2 ;
+1 WRITE !!,"Export data from October 1, 2000 thru September 30,2004 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 IF $$EXFILE
Begin DoDot:1
+5 WRITE !!,*7
+6 DO HELP^ACHS("FILEHELP","ACHSTX")
+7 QUIT
End DoDot:1
IF '$$DIR^XBDIR("Y","Continue","N","","","^D HELP^ACHS(""FILEHELP"",""ACHSTX"")",1)
GOTO END
+8 ;NOTE SHOULD NOT STORE THE FOUR YEAR EXPORT
+9 ;K DIC,X,Y
+10 ;S DIC="^ACHSTXST("_DUZ(2)_",1,",DIC(0)="Z",X=DT
+11 ;D ^DIC
+12 ;K DIC,X
+13 ;I Y>0,$P(Y(0),U,10)="N" G ^ACHSTXTT
+14 SET ACHSARCO=$PIECE(^ACHSF(DUZ(2),0),U,11)
+15 ;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
+16 USE IO(0)
+17 SET ACHSCRTN=""
L3 ;
+1 SET ACHSMDAT=$$DTAO
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO END
+3 ;
+4 KILL %ZIS,ACHSPPC,ACHSPPO
+5 ;
+6 SET %ZIS("A")="ENTER OUTPUT REPORT DEVICE # "
SET %ZIS="P"
+7 WRITE !
+8 DO ^%ZIS
+9 IF POP
GOTO END
+10 IF $DATA(IO("S"))
DO SLV^ACHSFU
+11 SET ACHSIO=IO
SET ACHSION=ION
+12 DO ^%ZISC
DO HOME^%ZIS
+13 ;
+14 DO ^ACHSTXP2
+15 QUIT
+16 ;
+17 ;
KILLGLBS ;EP - Kill unsubscripted work globals.
+1 ; ^ACHSDATA( - DHR (REC #2)
+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 ;
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 ;
