ACHSTXIT ; IHS/ITSC/PMF - EXPORT DATA (1/9) ; [ 12/06/2002 10:36 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
;IHS/SET/GTH ACHS*3.1*5 12/06/2002
; This is the lead program of the export process. You
;start here if you are exporting or REexporting
;
; In this program, we go through a whole series of checks,
;any one of which may stop the process or redirect it. If
;the program flow gets to the just above the first tag, then
;we are going to list POs to report on.
;
;
;if this is a 638 facility, ask them if they want to
;run a check first. If so, do it and quit
I $$PARM^ACHS(0,8)="Y" Q:$$STATCHK
;
;if the docs are locked, say so and quit
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
;get vars
D INIT
;
;verify the facility
D I 'OK D END Q
.W !!,"Export data will be made for ",$$LOC^ACHS
.S OK=$$DIR^XBDIR("Y","Is this Correct (Y/N) ","YES","","Export data will be made for "_$$LOC^ACHS,"",2)
.I $D(DUOUT)!$D(DTOUT) S OK=0
.Q
;
;if an export file already exists for today,
; tell them about it
; explain the consequences
; ask them if they are sure
I $$EXFILE D I 'OK D END Q
. W !!,*7
. D HELP^ACHS("FILEHELP","ACHSTX")
. S OK='$$DIR^XBDIR("Y","Continue","N","","","^D HELP^ACHS(""FILEHELP"",""ACHSTX"")",1)
. Q
;
;
;check to see if there is a record of exporting today.
K DIC,X,Y
S DIC="^ACHSTXST("_DUZ(2)_",1,",DIC(0)="Z",X=DT
D ^DIC
K DIC,X
;
;if an export happened today, and the tape save failed,
; go off and do it again
I Y>0,$P(Y(0),U,10)="N" G ^ACHSTXTT
;
;if an export happened today, and we are not REexporting,
; say so and quit
I 'ACHSREEX,$D(^ACHSTXST("C",DT,DUZ(2))) G TXFEF^ACHSTX8
;
;get the area accounting number. if it doesn't look right,
; say so and quit
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
;
;
;set the date for export. when is it not today?
S ACHSMDAT=$$DIR^XBDIR("D^"_DT_":"_$$HTFM^XLFDT($H+5),"ENTER DATE SENT TO AREA OFFICE ","T")
I $D(DUOUT)!$D(DTOUT) D END Q
;
;set device to report to
K %ZIS
S %ZIS("A")="ENTER OUTPUT REPORT DEVICE # ",%ZIS="P"
W !
D ^%ZIS
;
;if getting or opening the device failed, stop
I POP D END Q
;
I $D(IO("S")) D SLV^ACHSFU
;
S ACHSIO=IO
;
;close the device until later
D ^%ZISC,HOME^%ZIS
;
;MADE IT this far? now go get the POs to report on, and export them
D ^ACHSTX22
Q
;
;END of main program, start of sub routines
;
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)"
. I $$KILLOK^ZIBGCHAR($P(ACHS,U,2)) W !,$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($P(ACHS,U,2)))
. K @ACHS
. S @(ACHS_"(0)")=""
.Q
Q
;
ERROR ;EP.
X:$D(ACHSPPC) 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)
;
INIT ;
;get vars
D ^ACHSVAR
;
S ACHSRCT=0,ACHSCRTN=""
;
Q
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.
;;
;;###
ACHSTXIT ; IHS/ITSC/PMF - EXPORT DATA (1/9) ; [ 12/06/2002 10:36 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+3 ; This is the lead program of the export process. You
+4 ;start here if you are exporting or REexporting
+5 ;
+6 ; In this program, we go through a whole series of checks,
+7 ;any one of which may stop the process or redirect it. If
+8 ;the program flow gets to the just above the first tag, then
+9 ;we are going to list POs to report on.
+10 ;
+11 ;
+12 ;if this is a 638 facility, ask them if they want to
+13 ;run a check first. If so, do it and quit
+14 IF $$PARM^ACHS(0,8)="Y"
IF $$STATCHK
QUIT
+15 ;
+16 ;if the docs are locked, say so and quit
+17 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
+18 ;get vars
+19 DO INIT
+20 ;
+21 ;verify the facility
+22 Begin DoDot:1
+23 WRITE !!,"Export data will be made for ",$$LOC^ACHS
+24 SET OK=$$DIR^XBDIR("Y","Is this Correct (Y/N) ","YES","","Export data will be made for "_$$LOC^ACHS,"",2)
+25 IF $DATA(DUOUT)!$DATA(DTOUT)
SET OK=0
+26 QUIT
End DoDot:1
IF 'OK
DO END
QUIT
+27 ;
+28 ;if an export file already exists for today,
+29 ; tell them about it
+30 ; explain the consequences
+31 ; ask them if they are sure
+32 IF $$EXFILE
Begin DoDot:1
+33 WRITE !!,*7
+34 DO HELP^ACHS("FILEHELP","ACHSTX")
+35 SET OK='$$DIR^XBDIR("Y","Continue","N","","","^D HELP^ACHS(""FILEHELP"",""ACHSTX"")",1)
+36 QUIT
End DoDot:1
IF 'OK
DO END
QUIT
+37 ;
+38 ;
+39 ;check to see if there is a record of exporting today.
+40 KILL DIC,X,Y
+41 SET DIC="^ACHSTXST("_DUZ(2)_",1,"
SET DIC(0)="Z"
SET X=DT
+42 DO ^DIC
+43 KILL DIC,X
+44 ;
+45 ;if an export happened today, and the tape save failed,
+46 ; go off and do it again
+47 IF Y>0
IF $PIECE(Y(0),U,10)="N"
GOTO ^ACHSTXTT
+48 ;
+49 ;if an export happened today, and we are not REexporting,
+50 ; say so and quit
+51 IF 'ACHSREEX
IF $DATA(^ACHSTXST("C",DT,DUZ(2)))
GOTO TXFEF^ACHSTX8
+52 ;
+53 ;get the area accounting number. if it doesn't look right,
+54 ; say so and quit
+55 SET ACHSARCO=$PIECE(^ACHSF(DUZ(2),0),U,11)
+56 ;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
+57 ;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
+58 ;
+59 ;
+60 ;set the date for export. when is it not today?
+61 SET ACHSMDAT=$$DIR^XBDIR("D^"_DT_":"_$$HTFM^XLFDT($HOROLOG+5),"ENTER DATE SENT TO AREA OFFICE ","T")
+62 IF $DATA(DUOUT)!$DATA(DTOUT)
DO END
QUIT
+63 ;
+64 ;set device to report to
+65 KILL %ZIS
+66 SET %ZIS("A")="ENTER OUTPUT REPORT DEVICE # "
SET %ZIS="P"
+67 WRITE !
+68 DO ^%ZIS
+69 ;
+70 ;if getting or opening the device failed, stop
+71 IF POP
DO END
QUIT
+72 ;
+73 IF $DATA(IO("S"))
DO SLV^ACHSFU
+74 ;
+75 SET ACHSIO=IO
+76 ;
+77 ;close the device until later
+78 DO ^%ZISC
DO HOME^%ZIS
+79 ;
+80 ;MADE IT this far? now go get the POs to report on, and export them
+81 DO ^ACHSTX22
+82 QUIT
+83 ;
+84 ;END of main program, start of sub routines
+85 ;
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 IF $$KILLOK^ZIBGCHAR($PIECE(ACHS,U,2))
WRITE !,$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($PIECE(ACHS,U,2)))
+12 KILL @ACHS
+13 SET @(ACHS_"(0)")=""
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
ERROR ;EP.
+1 IF $DATA(ACHSPPC)
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 ;
INIT ;
+1 ;get vars
+2 DO ^ACHSVAR
+3 ;
+4 SET ACHSRCT=0
SET ACHSCRTN=""
+5 ;
+6 QUIT
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 ;;###
