Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSTXIT

ACHSTXIT.m

Go to the documentation of this file. 
  1. 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
  1.  ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  ; This is the lead program of the export process.  You
  1.  ;start here if you are exporting or REexporting
  1.  ;
  1.  ; In this program, we go through a whole series of checks,
  1.  ;any one of which may stop the process or redirect it.  If
  1.  ;the program flow gets to the just above the first tag, then
  1.  ;we are going to list POs to report on.
  1.  ;
  1.  ;
  1.  ;if this is a 638 facility, ask them if they want to
  1.  ;run a check first.  If so, do it and quit
  1.  I $$PARM^ACHS(0,8)="Y" Q:$$STATCHK
  1.  ;
  1.  ;if the docs are locked, say so and quit
  1.  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
  1.  ;get vars
  1.  D INIT
  1.  ;
  1.  ;verify the facility
  1.  D  I 'OK D END Q
  1.  .W !!,"Export data will be made for ",$$LOC^ACHS
  1.  .S OK=$$DIR^XBDIR("Y","Is this Correct (Y/N) ","YES","","Export data will be made for "_$$LOC^ACHS,"",2)
  1.  .I $D(DUOUT)!$D(DTOUT) S OK=0
  1.  .Q
  1.  ;
  1.  ;if an export file already exists for today,
  1.  ;  tell them about it
  1.  ;  explain the consequences
  1.  ;  ask them if they are sure
  1.  I $$EXFILE D  I 'OK D END Q
  1.  . W !!,*7
  1.  . D HELP^ACHS("FILEHELP","ACHSTX")
  1.  . S OK='$$DIR^XBDIR("Y","Continue","N","","","^D HELP^ACHS(""FILEHELP"",""ACHSTX"")",1)
  1.  . Q
  1.  ;
  1.  ;
  1.  ;check to see if there is a record of exporting today.
  1.  K DIC,X,Y
  1.  S DIC="^ACHSTXST("_DUZ(2)_",1,",DIC(0)="Z",X=DT
  1.  D ^DIC
  1.  K DIC,X
  1.  ;
  1.  ;if an export happened today, and the tape save failed,
  1.  ;  go off and do it again
  1.  I Y>0,$P(Y(0),U,10)="N" G ^ACHSTXTT
  1.  ;
  1.  ;if an export happened today, and we are not REexporting,
  1.  ;  say so and quit
  1.  I 'ACHSREEX,$D(^ACHSTXST("C",DT,DUZ(2))) G TXFEF^ACHSTX8
  1.  ;
  1.  ;get the area accounting number.  if it doesn't look right,
  1.  ;  say so and quit
  1.  S ACHSARCO=$P(^ACHSF(DUZ(2),0),U,11)
  1.  ;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
  1.  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
  1.  ;
  1.  ;
  1.  ;set the date for export.  when is it not today?
  1.  S ACHSMDAT=$$DIR^XBDIR("D^"_DT_":"_$$HTFM^XLFDT($H+5),"ENTER DATE SENT TO AREA OFFICE ","T")
  1.  I $D(DUOUT)!$D(DTOUT) D END Q
  1.  ;
  1.  ;set device to report to
  1.  K %ZIS
  1.  S %ZIS("A")="ENTER OUTPUT REPORT DEVICE # ",%ZIS="P"
  1.  W !
  1.  D ^%ZIS
  1.  ;
  1.  ;if getting or opening the device failed, stop
  1.  I POP D END Q
  1.  ;
  1.  I $D(IO("S")) D SLV^ACHSFU
  1.  ;
  1.  S ACHSIO=IO
  1.  ;
  1.  ;close the device until later
  1.  D ^%ZISC,HOME^%ZIS
  1.  ;
  1.  ;MADE IT this far?  now go get the POs to report on, and export them
  1.  D ^ACHSTX22
  1.  Q
  1.  ;
  1.  ;END of main program, start of sub routines
  1.  ;
  1. KILLGLBS ;EP - Kill unsubscripted work globals.
  1.  ; ^ACHSDATA( - DHR (REC #2)
  1.  ; ^ACHSTXPT( - Holds Patients to be exported. (Rec # 3)
  1.  ; ^ACHSTXVN( - Holds Vendor IENs to be exported. (Rec # 4)
  1.  ; ^ACHSTXOB( - Holds Document/Transaction to be exported. (Rec # 5)
  1.  ; ^ACHSTXPD( - Holds Paid Doc info to be exported to Area Office. (Rec # 6)
  1.  ; ^ACHSTXPG( - Holds Docs with statistical info to be exported to Data Center. (Rec # 7)
  1.  ;
  1.  N ACHS
  1.  F ACHS="^ACHSDATA","^ACHSTXPT","^ACHSTXVN","^ACHSTXOB","^ACHSTXPD","^ACHSTXPG" D
  1.  . W !,"Resetting ",ACHS,"(0)"
  1.  . I $$KILLOK^ZIBGCHAR($P(ACHS,U,2)) W !,$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($P(ACHS,U,2)))
  1.  . K @ACHS
  1.  . S @(ACHS_"(0)")=""
  1.  .Q
  1.  Q
  1.  ;
  1. ERROR ;EP.
  1.  X:$D(ACHSPPC) ACHSPPC
  1.  U IO(0)
  1.  W !!,*7,*7,*7,"AN ERROR HAS OCCURRED DURING EXPORT PLEASE NOTIFY AREA OFFICE "
  1.  D ^%ZISC
  1.  G JOBABEND^ACHSTX8
  1.  ;
  1. END ;
  1.  W !!?10,"JOB TERMINATED BY OPERATOR"
  1.  G JOBABEND^ACHSTX8
  1.  ;
  1. STATCHK() ; Check 638 stat data prior to export.
  1.  D HELP^ACHSTX7X
  1.  I $$DIR^XBDIR("Y","Run pre-export data check first","YES","","","^D HELP^ACHSTX7X",2) D ^ACHSTX7X Q 1
  1.  Q 0
  1.  ;
  1. EXFILE() ; Does export file exist?
  1.  NEW X,Y,Z
  1.  S Y=$$ASF^ACHS(DUZ(2))
  1.  I $$OS^ACHS=2 S Y=$E(Y,3,6)
  1.  S Y="ACHS"_Y_"."_$$JDT^ACHS(DT)
  1.  I $$LIST^%ZISH($$EX^ACHS,Y,.X)
  1.  S Z=""
  1.  F  S Z=$O(X(Z)) Q:'Z  I X(Z)=Y Q
  1.  Q $S('Z:0,1:1)
  1.  ;
  1. INIT ;
  1.  ;get vars
  1.  D ^ACHSVAR
  1.  ;
  1.  S ACHSRCT=0,ACHSCRTN=""
  1.  ;
  1.  Q
  1. FILEHELP ;EP -  ?? help text, from ACHS via DIR.
  1.  ;;
  1.  ;;     ***   AN EXPORT FILE FOR TODAY ALREADY EXISTS   ***
  1.  ;;
  1.  ;;An export file already exists in your export directory for today.
  1.  ;;You will overwrite the file if you continue.  If the file was
  1.  ;;correctly generated, the data in the file will be lost.  If you
  1.  ;;are certain that the data in the file was incorrectly generated,
  1.  ;;then proceed, forewarned.
  1.  ;;
  1.  ;;###