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

ACHSTXP.m

Go to the documentation of this file. 
  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
  1.  ;IHS/ITSC/FCJ ACHS*3.1*11 9.17.04 NEW ROUTINE FOR EXPORT OF DATA FR
  1.  ;  OCT 1,2000 THRU SEPT 30, 2004 ORIGINAL RTN ACHSTX
  1.  ;
  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.  D ^ACHSVAR
  1.  S ACHSRCT=0,ACHSREEX=0
  1. L2 ;
  1.  W !!,"Export data from October 1, 2000 thru September 30,2004 will be made for ",!,$$LOC^ACHS
  1.  G END:'$$DIR^XBDIR("Y","Is this Correct (Y/N) ","YES","","Export data will be made for "_$$LOC^ACHS,"",2)
  1.  G END:$D(DUOUT)!$D(DTOUT)
  1.  I $$EXFILE D  I '$$DIR^XBDIR("Y","Continue","N","","","^D HELP^ACHS(""FILEHELP"",""ACHSTX"")",1) G END
  1.  . W !!,*7
  1.  . D HELP^ACHS("FILEHELP","ACHSTX")
  1.  .Q
  1.  ;NOTE SHOULD NOT STORE THE FOUR YEAR EXPORT
  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.  ;I Y>0,$P(Y(0),U,10)="N" G ^ACHSTXTT
  1.  S ACHSARCO=$P(^ACHSF(DUZ(2),0),U,11)
  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.  U IO(0)
  1.  S ACHSCRTN=""
  1. L3 ;
  1.  S ACHSMDAT=$$DTAO
  1.  G END:$D(DUOUT)!$D(DTOUT)
  1.  ;
  1.  K %ZIS,ACHSPPC,ACHSPPO
  1.  ;
  1.  S %ZIS("A")="ENTER OUTPUT REPORT DEVICE # ",%ZIS="P"
  1.  W !
  1.  D ^%ZIS
  1.  G END:POP
  1.  I $D(IO("S")) D SLV^ACHSFU
  1.  S ACHSIO=IO,ACHSION=ION
  1.  D ^%ZISC,HOME^%ZIS
  1.  ;
  1.  D ^ACHSTXP2
  1.  Q
  1.  ;
  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.  . ;2/25/02  pmf  changes for cache
  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.  . S ACHSG=ACHS_"(0)" F  S ACHSG=$Q(@ACHSG) Q:ACHSG=""  K @ACHSG
  1.  . Q
  1.  K ACHSG
  1.  Q
  1.  ;
  1. DTAO() ;EP - Prompt for date sent to Area Office.
  1.  Q $$DIR^XBDIR("D^"_DT_":"_$$HTFM^XLFDT($H+5),"ENTER DATE SENT TO AREA OFFICE ","T")
  1.  ;
  1. ERROR ;EP.
  1.  X:$D(ACHSPCC) 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. 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.  ;