ACHSACO ; IHS/ITSC/PMF - AREA CONSOLIDATION (1/3) ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,11,13,18,19,21,23**;JUN 11,2001;Build 43
;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Clarified error message.
;IHS/SET/JVK ACHS*3.1*11 Add check for area to test ACHS version
; added a call to %ZISC in tag S15 - 10/5/00 - pmf
;ACHS*3.1*13 6.11.07 IHS/OIT/FCJ Added ufms work global
;ACHS*3.1*18 4.20.2010 IHS.OIT.FCJ Added ACHSPTH Var to replace calls to IM^ACHS and EX^ACHS-Tribal sites process data fr the export path
;
;CHECK TO SEE IF ACHS IS SET UP IN BULLETIN FILE
S X=$O(^XMB(3.6,"B","ACHS AREA BALANCES",0))
I 'X D D XIT^ACHSACOA Q
. W *7,!,"Mail Bulletin 'ACHS AREA BALANCES' does not exist."
. S X=$$DIR^XBDIR("E","Press RETURN...")
;
I '$O(^XMB(3.6,X,2,0)) D D XIT^ACHSACOA Q
. W *7,!,"Mail Bulletin 'ACHS AREA BALANCES' does not have a MAIL GROUP."
. S X=$$DIR^XBDIR("E","Press RETURN...")
;ACHS*3.1*21 CHECK FOR ACCOUNTING POINT
S ACHSAPN=$P(^AUTTSITE(1,0),U,2)
I ACHSAPN']"" D Q
. W *7,!,"ACCOUNTING POINT NUMBER is missing from RPMS SITE file...",!
. D XIT^ACHSACOA
;SHOW AREA OFFICE PARAMETERS SETTINGS
W !!," PROCESS FI DATA parameter = '",$$AOP^ACHS(2,3),"'"
W !,"PROCESS AREA OFFICE DATA parameter = '",$$AOP^ACHS(2,4),"'"
;W !," HAS/CORE CONTROL parameter = '",$$AOP^ACHS(2,2),"'",!! ;ACHS*3.1*21
;
;ACHS*3.1*21 ADDED TEST FOR SPLIT OUT NOT COMPLETED WILL RUN SPLIT OUT
S Y=1
I $G(^ACHSPCC("PROC"))="C" D
.W !!,"********** SPLIT OUT HAS NOT BEEN COMPLETED **********"
.I $$DIR^XBDIR("Y","Do you want to Continue to splitout files","Y","","","",1) D ^ACHSPCC1
.I $$DIR^XBDIR("Y","Do you want to Continue to consolidation of files","Y","","","",1)
;ACHS*3.1*13 IHS/OIT/FCJ Added ufms workglobal to nxt line
Q:Y'=1
;ACHS*3.1*23 ADD ACHSPG2 - NEW ICD10 FORMAT
F ACHS="^ACHSPCC","^ACHSBCBS","^ACHSAOPD","^ACHSAOVU","^ACHSZOCT","^ACHSPIG","^ACHSPG2","^ACHSSVR","^ACHSCORE","^ACHSUFMS" D
. W !,"KILL'ing work global ",ACHS
. I $$KILLOK^ZIBGCHAR($P(ACHS,U,2)) W !,$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($P(ACHS,U,2)))
. K @ACHS ; Kill unsubscripted work globals.
. S @(ACHS_"(0)")=""
;
;
W !?10,"Previously Consolidated CHS Facility Data has been Deleted",!
;
K ^TMP("ACHSACO",$J)
;
D RSLT(">>> PLEASE ENSURE THE AREA CHS OFFICER RECEIVES THIS MESSAGE <<<")
D RSLT("ASUFAC"_$J("Export Date",15)_$J("Adv of Allowance",18)_$J("Obligated YTD",18)_$J("Balance",18))
D RSLT("------"_$J("-------------",15)_$J("----------------",18)_$J("---------------",18)_$J("---------------",18))
;
S ACHSFN="" ;ACHS*3.1*19
S ^ACHSPCC("COUNT")=0,ACHSOK=0
S ^ACHSUFMS("COUNT")=0,^ACHSUFMS(0)=0
K ACHSZFAC
S ACHSDTJL=$E(DT,2,3)_$$JDT^ACHS(DT,1)
S1 ;
S %ZIS("A")="Enter Printer Device for Consolidation Report: ",%ZIS="P"
D ^%ZIS
I POP U IO(0) W !,"Printer Not Available - JOB CANCELLED",! D XIT^ACHSACOA Q
S ACHSPTR=IO
I $D(IO("S")) D SLV^ACHSFU,^%ZISC ;IF SLAVE CHOSEN DO SLAVE SETUP
; THEN CLOSE EVERYTHING?????
;
FSEL ;
;RETURN A LIST OF FILES TO CONSOLIDATE E.G. ACHS202100.221
K ACHSLIST
;
; IMPORT PATH=$P(^AUTTSITE(1,1),U)
;GET ALL FILES STARTING WITH ACHS AND PUT IN ARRAY ACHSLIST
;THE FORMAT FOR ACHSLIST IS:
; P^1=FILENAME
; P^2=FACILITY NAME
; P^3=VENDOR NUMBER????
; P^4=DATE OF GLOBAL SAVE
; P^5=Y IF CHOSEN?????
;ACHS*3.1*18 IHS.OIT.FCJ ADDED LINE AND MODIFIED NXT LINE;ACHS*3.1*21 ADDED PARA FOR DIRECTORY
S ACHSPTH=$$AOP^ACHS(3,1)
I ACHSPTH="" S X=$$ASF^ACHS(DUZ(2)),ACHSPTH=$S((X=808301)!(X=252611):$$EX^ACHS,1:$$IM^ACHS)
I $$LIST^%ZISH(ACHSPTH,"ACHS*",.ACHSLIST) D ERROR^ACHSTCK1 D XIT^ACHSACOA Q ;ACHS*3.1*18
;I $$LIST^%ZISH($$IM^ACHS,"ACHS*",.ACHSLIST) D ERROR^ACHSTCK1 D XIT^ACHSACOA Q ;ACHS*3.1*18
;
;GO THRU LIST OF FILES TO CONSOLIDATE
S ACHSCNT=0,ACHSNCNT=0
F S ACHSCNT=$O(ACHSLIST(ACHSCNT)) Q:'ACHSCNT D Q:$G(ACHSJFLG)
.;
.;ELIMINATE IF NOT AN ACCEPTED FILE NAME FORMAT ; ACHS*3.1*19 ADDED NEW FORMAT FOR PATCH 19
. ;I (ACHSLIST(ACHSCNT)'?1"ACHS"4.6N1"."1.3N) K ACHSLIST(ACHSCNT) Q
. I (ACHSLIST(ACHSCNT)'?1"ACHS"4.6N1"."1.8N.1"_".6N) K ACHSLIST(ACHSCNT) Q
.;TRY TO OPEN THE FILE
.;ACHS*3.1*18 IHS.OIT.FCJ changed $$IM^ACHS TO ACHSPTH IN NXT LINE
. I $$OPEN^%ZISH(ACHSPTH,ACHSLIST(ACHSCNT),"R") D ERROR^ACHSTCK1 Q ;ACHS*3.1*18
. S ACHSNCNT=ACHSNCNT+1
.;
.;
.;THE FORMAT IS THE SAVE OF GLOBAL ^ACHSDATA(
. U IO
. R X:DTIME ; SAC - FILE READ
. S $P(ACHSLIST(ACHSCNT),U,4)=X ;READ DATE/TIME STAMP
. ;THIS IS THE DATE WHEN SAVED NOT SENT
.;
.;
.R X:DTIME ;READ AREA ;SAC-FILE READ
.R X:DTIME ;READ GLOBAL NODE ;SAC-FILE READ
.R X:DTIME ;READ FIRST GLOBAL RECORD ;SAC-FILE READ
.;
.S $P(ACHSLIST(ACHSCNT),U,2)=$P(X,U,2) ;FACILITY NAME
.S $P(ACHSLIST(ACHSCNT),U,3)=$P(X,U,7) ;TOTAL ALL RECORD TYPES
.;ITSC/SET/JVK-ACHS*3.1*11 CHECK THE FILE VERSION NO.
.S $P(ACHSLIST(ACHSCNT),U,6)=$P(X,U,12) ;VERSION OF ACHS
.D ^%ZISC ;CLOSE ALL DEVICES
;
I $G(ACHSJFLG) D XIT^ACHSACOA Q
;
;
S ACHSCNT=ACHSNCNT
K ACHSNCNT
;ACHS*3.1*18 IHS.OIT.FCJ changed $$IM^ACHS TO ACHSPTH IN NXT LINE
;I ACHSCNT<1 U IO(0) W *7,!!?5,"No Facility Files Available for Processing",!! D XIT^ACHSACOA Q;IHS/SET/GTH ACHS*3.1*5 12/06/2002
I ACHSCNT<1 U IO(0) W *7,!!?5,"No Facility Files (ACHS*) Available for Processing in the ",ACHSPTH," directory.",!! D XIT^ACHSACOA Q ;ACHS*3.1*5 ACHS*3.1*18
; Reorder list if some files weren't Facility files.
;
;
S (X,Y)=0
F S X=$O(ACHSLIST(X)),Y=Y+1 Q:'X S Z=ACHSLIST(X) K ACHSLIST(X) S ACHSLIST(Y)=Z
;
S2 ;
F %=1:1 Q:'$D(ACHSLIST(%)) S:$P(ACHSLIST(%),U,5)="Y" $P(ACHSLIST(%),U,5)=""
S2A ;
;
K ACHSPLST
S ACHSZ=0
F S ACHSZ=$O(ACHSLIST(ACHSZ)) Q:'ACHSZ S $P(ACHSLIST(ACHSZ),U,5)=""
;
;
D FDISP ;FILE LIST DISPLAY
;
;LETS CHOOSE FILE TO PROCESS
SEL ;
S Y=$$DIR^XBDIR("L^1:"_ACHSCNT,"Enter Seq # of File to Process (1-"_ACHSCNT_" for All)","","","","",1)
;
I $D(DUOUT)!($D(DTOUT)) U IO(0) W !!,"No Files Selected for Consolidation - Job Terminated",! D XIT^ACHSACOA Q
;
;
F ACHSZ=1:1:ACHSCNT Q:$P(Y,",",ACHSZ)="" S Z=$P(Y,",",ACHSZ) S:+$P(ACHSLIST(Z),U,3)>0 $P(ACHSLIST(Z),U,5)="Y"
;ITSC/SET/JVK ACHS*3.1*11
I $P(ACHSLIST(Z),U,6)="" U IO(0) W !!,"File(s) with a version of unknown are not compatiable with current CHS version",!,?35,"Job Terminiated",! D XIT^ACHSACOA Q
;
;
K ACHSPLST
S ACHSJ=0
F ACHSI=1:1:ACHSCNT I $P(ACHSLIST(ACHSI),U,5)="Y" S ACHSJ=ACHSJ+1,ACHSPLST(ACHSJ)=$P(ACHSLIST(ACHSI),U)
;
D FDISP ;FILE LIST DISPLAY
;
U IO(0)
S Y=$$DIR^XBDIR("Y","Files Selected Above will Now be Processed - Is This Correct? (Y/N)","N","","","",1)
I Y=0 G S2A
I $D(DTOUT)!($D(DUOUT)) U IO(0) W !,"Job Cancelled",! D XIT^ACHSACOA Q
;
;
FIL1 ;
S ACHSZ=""
FIL2 ;
F S ACHSZ=$O(ACHSPLST(ACHSZ)) Q:ACHSZ="" D
.;
.;I ACHSZ="" D REPORT^ACHSACOA Q ;PRINT REPORTS
.;
.;TRY AND OPEN THE FILE
.;ACHS*3.1*18 IHS.OIT.FCJ changed $$IM^ACHS TO ACHSPTH IN NXT LINE
.I $$OPEN^%ZISH(ACHSPTH,$P(ACHSPLST(ACHSZ),U,1),"R") D ERROR^ACHSTCK1 D XIT^ACHSACOA ;ACHS*3.1*18
RDHDR .; Read the header of the file being processed.
.U IO
.R X:DTIME ;READ BLANK LINE ;SAC-FILE READ
.R X:DTIME ;READ BLANK LINE ;SAC-FILE READ
.R ACHSXD1:DTIME ;READ GLOBAL NODE ;SAC-FILE READ
.R ACHSXD2:DTIME ;READ RECORD ;SAC-FILE READ
.;
.U IO(0)
.;
.S ACHSFN=$P(ACHSPLST(ACHSZ),U) ;ACHS*3.1*19
.S ACHSFACD=$P(ACHSXD2,U) ;'ASUFAC'
.S ACHSGBL=$P($P(ACHSXD1,"("),U,2) ;GLOBAL NAME
.;
.;EXPECTING GLOBAL SAVES OF THESE TWO GLOBALS SEE "EXPORT GLOBALS" DOCS
.I ACHSGBL'="ACHSDATA",(ACHSGBL'="ACHSTXDT") D Q
..W !,"CONTAINS UNRECOGNIZED DATA"
..W !,"FACILITY CODE : '",$G(ACHSFACD,"UNDEFINED"),"'"
..W !,"GLOBAL NAME : '",$G(ACHSGBL,"UNDEFINED"),"'",!
..D ABEND^ACHSACOA
.;
.W !?20,U,ACHSGBL,"( Data -- As Listed Below",!
.S X=$P(ACHSXD2,U) ;USE FACILITY ID READ IN FILE
.S DIC="^AUTTLOC(" ;LOOK AT AREA LOCATION FILE
.S DIC(0)="" ;
.S D="C" ;USE THE ASUFAC X-REF
.D IX^DIC
.K DIC,D
.;
.I +Y<0 U IO(0) D Q
..W *7,!,"FACILITY LOOK-UP ERROR ON FACILITY '",$P(ACHSXD2,U,2)
..W "', ASUFAC INDEX = '",X,"' WAS NOT FOUND IN THE 'ASUFAC' CROSS"
..W "REFERENCE IN '^AUTTLOC LOCATION FILE'"
..S IONOFF="" D ^%ZISC D ABEND^ACHSACOA
.;
.S:+Y>0 ACHSFCPT=+Y
.S ACHSDRUN=$P(ACHSXD2,U,3) ;DATE RUN
.S ACHSFREC=$P(ACHSXD2,U,4) ;DATE OF FIRST RECORD
.S ACHSLREC=$P(ACHSXD2,U,5) ;DATE OF LAST RECORD
.S ACHSNRCD=$P(ACHSXD2,U,7) ;NUMBER OF RECORDS
.S ACHSSTV=$P(ACHSXD2,U,12) ;STAT RECORD VERSION ;ACHS*3.1*23
.;
.W !,"FACILITY NAME",?20,":",?25,$P(ACHSXD2,U,2)
.W !,"DATE EXPORT RUN",?20,":",?25,$$FMTE^XLFDT(ACHSDRUN)
.W !,"DATE OF FIRST RECORD",?20,":",?25,$$FMTE^XLFDT(ACHSFREC)
.W !,"DATE OF LAST RECORD",?20,":",?25,$$FMTE^XLFDT(ACHSLREC)
.W !,"NUMBER OF RECORDS",?20,":",?25,ACHSNRCD,!
.K ACHSZFIF
S15F .;
.;IF NO ENTRY IN THE LOG FILE CONTINUE PROCESS
.;USE FACILITY PTR FROM ^AUTTLOC AND LOOK AT LOG FILE
.;ACHS*3.1*21;ALLOW PROCESSING IF DEPENDING ON USER RESPONSE
.;I '$D(^ACHSAOLG(ACHSFCPT,1,ACHSDRUN)) D S15X Q
.S Y=1
.I $D(^ACHSAOLG(ACHSFCPT,1,ACHSDRUN)) D
..U IO(0)
..; INSTITUTION NAME
..W !!,*7,"DATA ALREADY PROCESSED FOR: ",$E($P($G(^DIC(4,ACHSFCPT,0)),U),1,20)," EXPORT DATE OF: ",$$FMTE^XLFDT(ACHSDRUN),!!
..W !?10,"******* ARE YOU SURE YOU WANT TO REPROCESS *******"
..W !,"******* THIS COULD CAUSE DUPLICATE RECORDS AT UFMS AND THE FI *******",!
..;I $$DIR^XBDIR("E","Enter <RETURN> to Continue Processing OR ^ TO EXIT")
..I $$DIR^XBDIR("Y","Enter YES to process the file or NO to skip the file.")
.I Y=1 D S15X Q
.;ACHS*3.1*21 end of changes
.;
.;added next line - 10/5/00 - pmf
.;now CLOSE the file, since we are not going to process it.
.D ^%ZISC
.;
D REPORT^ACHSACOA ;DO CONSOLIDATION REPORTS
I $$DIR^XBDIR("Y","Do you want to Continue to splitout files","Y","","","",1) D ^ACHSPCC1 Q ;ACHS*3.1*21
Q
;
;
S15X ;
S ^ACHSPCC("PROC")="C" ;ACHS*3.1*21
D RSLT(ACHSFACD_$J($$FMTE^XLFDT(ACHSDRUN),15)_$J("$"_$FN($P(ACHSXD2,U,10),",",2),18)_$J("$"_$FN($P(ACHSXD2,U,11),",",2),18)_$J("$"_$FN($P(ACHSXD2,U,10)-$P(ACHSXD2,U,11),",",2),18))
;
;
D ^ACHSACO1 ;AREA CONSOLIDATION (2/3) INITIALIZE COUNTERS
;MAIN PROCESSING LOOP
;
;
I $D(ACHSOK) I 'ACHSOK D ABEND^ACHSACOA Q
;
;
S $P(ACHSZFAC(ACHSFCPT,ACHSDRUN,0),U,2)=ACHSDRUN
S $P(ACHSZFAC(ACHSFCPT,ACHSDRUN,0),U,3)=ACHSFREC
S $P(ACHSZFAC(ACHSFCPT,ACHSDRUN,0),U,4)=ACHSLREC
S $P(ACHSZFAC(ACHSFCPT,ACHSDRUN,0),U,5)=ACHSNRCD
;
U IO(0)
I $$DIR^XBDIR("E"," Press RETURN to Process NEXT FILE")
Q
;
FDISP ;
U IO(0)
W @IOF,"Files available for CHS Consolidation are listed Below:"
W !,"Seq",?7,"File Name",?32,"Facility Name",?53,"# Rcds",?61,"Export Date Process",! ;ACHS*3.1*19
S ACHSI=""
F S ACHSI=$O(ACHSLIST(ACHSI)) Q:+ACHSI=0 D
.S X=ACHSLIST(ACHSI)
.U IO(0)
.W !,$J(ACHSI,3),?5,$E($P(X,U,1),1,30),?32,$E($P(X,U,2),1,20),?53,$J($P(X,U,3),6),?61,$P($P(X,U,4),"@") ;ACHS*3.1*19
.S ACHSKJRY=X,ACHSKJRX=$P($P(X,U,1),".",2),ACHSKJRX=$$JTF^ACHS(ACHSKJRX)
.; Do a FM Lookup based on the ASUFAC for the file being processed
.S ACHSX=ACHSKJRY
.D FACLKUP
.I +Y<0 U IO(0) W *7,!,"==>FACILITY CODE LOOK-UP ERROR ON CODE '",X,"'" Q
.S X=ACHSKJRX
.K ACHSKJRX
.I '$D(^ACHSAOLG(+Y,1,X,0)) D FD2 Q
.S Z=$P($G(^ACHSAOLG(+Y,1,X,0)),U,5)
.I Z="" S Z=9999999
.S $P(ACHSLIST(ACHSI),U,5)=Z
.W ?70,$E(Z,4,5),"/",$E(Z,6,7),"/",$E(Z,2,3)
Q
;
FD2 ;
W ?75,$P(ACHSLIST(ACHSI),U,5) ;ACHS*3.1*19
Q
;
;
FACLKUP ;
S X=$E($P(ACHSX,".",1),5,10)
S DIC(0)="ZM" ;
S DIC="^AUTTLOC(" ;AREA LOCATION FILE
S D="C" ;USE ASUFAC X-REF
D ^DIC
I Y<1 K D S X=$P(ACHSLIST(ACHSI),U,2) D ^DIC
Q
;
RSLT(X) ;
S ^(0)=$G(^TMP("ACHSACO",$J,0))+1,^(^(0))=X
Q
;
ACHSACO ; IHS/ITSC/PMF - AREA CONSOLIDATION (1/3) ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,11,13,18,19,21,23**;JUN 11,2001;Build 43
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Clarified error message.
+3 ;IHS/SET/JVK ACHS*3.1*11 Add check for area to test ACHS version
+4 ; added a call to %ZISC in tag S15 - 10/5/00 - pmf
+5 ;ACHS*3.1*13 6.11.07 IHS/OIT/FCJ Added ufms work global
+6 ;ACHS*3.1*18 4.20.2010 IHS.OIT.FCJ Added ACHSPTH Var to replace calls to IM^ACHS and EX^ACHS-Tribal sites process data fr the export path
+7 ;
+8 ;CHECK TO SEE IF ACHS IS SET UP IN BULLETIN FILE
+9 SET X=$ORDER(^XMB(3.6,"B","ACHS AREA BALANCES",0))
+10 IF 'X
Begin DoDot:1
+11 WRITE *7,!,"Mail Bulletin 'ACHS AREA BALANCES' does not exist."
+12 SET X=$$DIR^XBDIR("E","Press RETURN...")
End DoDot:1
DO XIT^ACHSACOA
QUIT
+13 ;
+14 IF '$ORDER(^XMB(3.6,X,2,0))
Begin DoDot:1
+15 WRITE *7,!,"Mail Bulletin 'ACHS AREA BALANCES' does not have a MAIL GROUP."
+16 SET X=$$DIR^XBDIR("E","Press RETURN...")
End DoDot:1
DO XIT^ACHSACOA
QUIT
+17 ;ACHS*3.1*21 CHECK FOR ACCOUNTING POINT
+18 SET ACHSAPN=$PIECE(^AUTTSITE(1,0),U,2)
+19 IF ACHSAPN']""
Begin DoDot:1
+20 WRITE *7,!,"ACCOUNTING POINT NUMBER is missing from RPMS SITE file...",!
+21 DO XIT^ACHSACOA
End DoDot:1
QUIT
+22 ;SHOW AREA OFFICE PARAMETERS SETTINGS
+23 WRITE !!," PROCESS FI DATA parameter = '",$$AOP^ACHS(2,3),"'"
+24 WRITE !,"PROCESS AREA OFFICE DATA parameter = '",$$AOP^ACHS(2,4),"'"
+25 ;W !," HAS/CORE CONTROL parameter = '",$$AOP^ACHS(2,2),"'",!! ;ACHS*3.1*21
+26 ;
+27 ;ACHS*3.1*21 ADDED TEST FOR SPLIT OUT NOT COMPLETED WILL RUN SPLIT OUT
+28 SET Y=1
+29 IF $GET(^ACHSPCC("PROC"))="C"
Begin DoDot:1
+30 WRITE !!,"********** SPLIT OUT HAS NOT BEEN COMPLETED **********"
+31 IF $$DIR^XBDIR("Y","Do you want to Continue to splitout files","Y","","","",1)
DO ^ACHSPCC1
+32 IF $$DIR^XBDIR("Y","Do you want to Continue to consolidation of files","Y","","","",1)
End DoDot:1
+33 ;ACHS*3.1*13 IHS/OIT/FCJ Added ufms workglobal to nxt line
+34 IF Y'=1
QUIT
+35 ;ACHS*3.1*23 ADD ACHSPG2 - NEW ICD10 FORMAT
+36 FOR ACHS="^ACHSPCC","^ACHSBCBS","^ACHSAOPD","^ACHSAOVU","^ACHSZOCT","^ACHSPIG","^ACHSPG2","^ACHSSVR","^ACHSCORE","^ACHSUFMS"
Begin DoDot:1
+37 WRITE !,"KILL'ing work global ",ACHS
+38 IF $$KILLOK^ZIBGCHAR($PIECE(ACHS,U,2))
WRITE !,$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($PIECE(ACHS,U,2)))
+39 ; Kill unsubscripted work globals.
KILL @ACHS
+40 SET @(ACHS_"(0)")=""
End DoDot:1
+41 ;
+42 ;
+43 WRITE !?10,"Previously Consolidated CHS Facility Data has been Deleted",!
+44 ;
+45 KILL ^TMP("ACHSACO",$JOB)
+46 ;
+47 DO RSLT(">>> PLEASE ENSURE THE AREA CHS OFFICER RECEIVES THIS MESSAGE <<<")
+48 DO RSLT("ASUFAC"_$JUSTIFY("Export Date",15)_$JUSTIFY("Adv of Allowance",18)_$JUSTIFY("Obligated YTD",18)_$JUSTIFY("Balance",18))
+49 DO RSLT("------"_$JUSTIFY("-------------",15)_$JUSTIFY("----------------",18)_$JUSTIFY("---------------",18)_$JUSTIFY("---------------",18))
+50 ;
+51 ;ACHS*3.1*19
SET ACHSFN=""
+52 SET ^ACHSPCC("COUNT")=0
SET ACHSOK=0
+53 SET ^ACHSUFMS("COUNT")=0
SET ^ACHSUFMS(0)=0
+54 KILL ACHSZFAC
+55 SET ACHSDTJL=$EXTRACT(DT,2,3)_$$JDT^ACHS(DT,1)
S1 ;
+1 SET %ZIS("A")="Enter Printer Device for Consolidation Report: "
SET %ZIS="P"
+2 DO ^%ZIS
+3 IF POP
USE IO(0)
WRITE !,"Printer Not Available - JOB CANCELLED",!
DO XIT^ACHSACOA
QUIT
+4 SET ACHSPTR=IO
+5 ;IF SLAVE CHOSEN DO SLAVE SETUP
IF $DATA(IO("S"))
DO SLV^ACHSFU
DO ^%ZISC
+6 ; THEN CLOSE EVERYTHING?????
+7 ;
FSEL ;
+1 ;RETURN A LIST OF FILES TO CONSOLIDATE E.G. ACHS202100.221
+2 KILL ACHSLIST
+3 ;
+4 ; IMPORT PATH=$P(^AUTTSITE(1,1),U)
+5 ;GET ALL FILES STARTING WITH ACHS AND PUT IN ARRAY ACHSLIST
+6 ;THE FORMAT FOR ACHSLIST IS:
+7 ; P^1=FILENAME
+8 ; P^2=FACILITY NAME
+9 ; P^3=VENDOR NUMBER????
+10 ; P^4=DATE OF GLOBAL SAVE
+11 ; P^5=Y IF CHOSEN?????
+12 ;ACHS*3.1*18 IHS.OIT.FCJ ADDED LINE AND MODIFIED NXT LINE;ACHS*3.1*21 ADDED PARA FOR DIRECTORY
+13 SET ACHSPTH=$$AOP^ACHS(3,1)
+14 IF ACHSPTH=""
SET X=$$ASF^ACHS(DUZ(2))
SET ACHSPTH=$SELECT((X=808301)!(X=252611):$$EX^ACHS,1:$$IM^ACHS)
+15 ;ACHS*3.1*18
IF $$LIST^%ZISH(ACHSPTH,"ACHS*",.ACHSLIST)
DO ERROR^ACHSTCK1
DO XIT^ACHSACOA
QUIT
+16 ;I $$LIST^%ZISH($$IM^ACHS,"ACHS*",.ACHSLIST) D ERROR^ACHSTCK1 D XIT^ACHSACOA Q ;ACHS*3.1*18
+17 ;
+18 ;GO THRU LIST OF FILES TO CONSOLIDATE
+19 SET ACHSCNT=0
SET ACHSNCNT=0
+20 FOR
SET ACHSCNT=$ORDER(ACHSLIST(ACHSCNT))
IF 'ACHSCNT
QUIT
Begin DoDot:1
+21 ;
+22 ;ELIMINATE IF NOT AN ACCEPTED FILE NAME FORMAT ; ACHS*3.1*19 ADDED NEW FORMAT FOR PATCH 19
+23 ;I (ACHSLIST(ACHSCNT)'?1"ACHS"4.6N1"."1.3N) K ACHSLIST(ACHSCNT) Q
+24 IF (ACHSLIST(ACHSCNT)'?1"ACHS"4.6N1"."1.8N.1"_".6N)
KILL ACHSLIST(ACHSCNT)
QUIT
+25 ;TRY TO OPEN THE FILE
+26 ;ACHS*3.1*18 IHS.OIT.FCJ changed $$IM^ACHS TO ACHSPTH IN NXT LINE
+27 ;ACHS*3.1*18
IF $$OPEN^%ZISH(ACHSPTH,ACHSLIST(ACHSCNT),"R")
DO ERROR^ACHSTCK1
QUIT
+28 SET ACHSNCNT=ACHSNCNT+1
+29 ;
+30 ;
+31 ;THE FORMAT IS THE SAVE OF GLOBAL ^ACHSDATA(
+32 USE IO
+33 ; SAC - FILE READ
READ X:DTIME
+34 ;READ DATE/TIME STAMP
SET $PIECE(ACHSLIST(ACHSCNT),U,4)=X
+35 ;THIS IS THE DATE WHEN SAVED NOT SENT
+36 ;
+37 ;
+38 ;READ AREA ;SAC-FILE READ
READ X:DTIME
+39 ;READ GLOBAL NODE ;SAC-FILE READ
READ X:DTIME
+40 ;READ FIRST GLOBAL RECORD ;SAC-FILE READ
READ X:DTIME
+41 ;
+42 ;FACILITY NAME
SET $PIECE(ACHSLIST(ACHSCNT),U,2)=$PIECE(X,U,2)
+43 ;TOTAL ALL RECORD TYPES
SET $PIECE(ACHSLIST(ACHSCNT),U,3)=$PIECE(X,U,7)
+44 ;ITSC/SET/JVK-ACHS*3.1*11 CHECK THE FILE VERSION NO.
+45 ;VERSION OF ACHS
SET $PIECE(ACHSLIST(ACHSCNT),U,6)=$PIECE(X,U,12)
+46 ;CLOSE ALL DEVICES
DO ^%ZISC
End DoDot:1
IF $GET(ACHSJFLG)
QUIT
+47 ;
+48 IF $GET(ACHSJFLG)
DO XIT^ACHSACOA
QUIT
+49 ;
+50 ;
+51 SET ACHSCNT=ACHSNCNT
+52 KILL ACHSNCNT
+53 ;ACHS*3.1*18 IHS.OIT.FCJ changed $$IM^ACHS TO ACHSPTH IN NXT LINE
+54 ;I ACHSCNT<1 U IO(0) W *7,!!?5,"No Facility Files Available for Processing",!! D XIT^ACHSACOA Q;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+55 ;ACHS*3.1*5 ACHS*3.1*18
IF ACHSCNT<1
USE IO(0)
WRITE *7,!!?5,"No Facility Files (ACHS*) Available for Processing in the ",ACHSPTH," directory.",!!
DO XIT^ACHSACOA
QUIT
+56 ; Reorder list if some files weren't Facility files.
+57 ;
+58 ;
+59 SET (X,Y)=0
+60 FOR
SET X=$ORDER(ACHSLIST(X))
SET Y=Y+1
IF 'X
QUIT
SET Z=ACHSLIST(X)
KILL ACHSLIST(X)
SET ACHSLIST(Y)=Z
+61 ;
S2 ;
+1 FOR %=1:1
IF '$DATA(ACHSLIST(%))
QUIT
IF $PIECE(ACHSLIST(%),U,5)="Y"
SET $PIECE(ACHSLIST(%),U,5)=""
S2A ;
+1 ;
+2 KILL ACHSPLST
+3 SET ACHSZ=0
+4 FOR
SET ACHSZ=$ORDER(ACHSLIST(ACHSZ))
IF 'ACHSZ
QUIT
SET $PIECE(ACHSLIST(ACHSZ),U,5)=""
+5 ;
+6 ;
+7 ;FILE LIST DISPLAY
DO FDISP
+8 ;
+9 ;LETS CHOOSE FILE TO PROCESS
SEL ;
+1 SET Y=$$DIR^XBDIR("L^1:"_ACHSCNT,"Enter Seq # of File to Process (1-"_ACHSCNT_" for All)","","","","",1)
+2 ;
+3 IF $DATA(DUOUT)!($DATA(DTOUT))
USE IO(0)
WRITE !!,"No Files Selected for Consolidation - Job Terminated",!
DO XIT^ACHSACOA
QUIT
+4 ;
+5 ;
+6 FOR ACHSZ=1:1:ACHSCNT
IF $PIECE(Y,",",ACHSZ)=""
QUIT
SET Z=$PIECE(Y,",",ACHSZ)
IF +$PIECE(ACHSLIST(Z),U,3)>0
SET $PIECE(ACHSLIST(Z),U,5)="Y"
+7 ;ITSC/SET/JVK ACHS*3.1*11
+8 IF $PIECE(ACHSLIST(Z),U,6)=""
USE IO(0)
WRITE !!,"File(s) with a version of unknown are not compatiable with current CHS version",!,?35,"Job Terminiated",!
DO XIT^ACHSACOA
QUIT
+9 ;
+10 ;
+11 KILL ACHSPLST
+12 SET ACHSJ=0
+13 FOR ACHSI=1:1:ACHSCNT
IF $PIECE(ACHSLIST(ACHSI),U,5)="Y"
SET ACHSJ=ACHSJ+1
SET ACHSPLST(ACHSJ)=$PIECE(ACHSLIST(ACHSI),U)
+14 ;
+15 ;FILE LIST DISPLAY
DO FDISP
+16 ;
+17 USE IO(0)
+18 SET Y=$$DIR^XBDIR("Y","Files Selected Above will Now be Processed - Is This Correct? (Y/N)","N","","","",1)
+19 IF Y=0
GOTO S2A
+20 IF $DATA(DTOUT)!($DATA(DUOUT))
USE IO(0)
WRITE !,"Job Cancelled",!
DO XIT^ACHSACOA
QUIT
+21 ;
+22 ;
FIL1 ;
+1 SET ACHSZ=""
FIL2 ;
+1 FOR
SET ACHSZ=$ORDER(ACHSPLST(ACHSZ))
IF ACHSZ=""
QUIT
Begin DoDot:1
+2 ;
+3 ;I ACHSZ="" D REPORT^ACHSACOA Q ;PRINT REPORTS
+4 ;
+5 ;TRY AND OPEN THE FILE
+6 ;ACHS*3.1*18 IHS.OIT.FCJ changed $$IM^ACHS TO ACHSPTH IN NXT LINE
+7 ;ACHS*3.1*18
IF $$OPEN^%ZISH(ACHSPTH,$PIECE(ACHSPLST(ACHSZ),U,1),"R")
DO ERROR^ACHSTCK1
DO XIT^ACHSACOA
RDHDR ; Read the header of the file being processed.
+1 USE IO
+2 ;READ BLANK LINE ;SAC-FILE READ
READ X:DTIME
+3 ;READ BLANK LINE ;SAC-FILE READ
READ X:DTIME
+4 ;READ GLOBAL NODE ;SAC-FILE READ
READ ACHSXD1:DTIME
+5 ;READ RECORD ;SAC-FILE READ
READ ACHSXD2:DTIME
+6 ;
+7 USE IO(0)
+8 ;
+9 ;ACHS*3.1*19
SET ACHSFN=$PIECE(ACHSPLST(ACHSZ),U)
+10 ;'ASUFAC'
SET ACHSFACD=$PIECE(ACHSXD2,U)
+11 ;GLOBAL NAME
SET ACHSGBL=$PIECE($PIECE(ACHSXD1,"("),U,2)
+12 ;
+13 ;EXPECTING GLOBAL SAVES OF THESE TWO GLOBALS SEE "EXPORT GLOBALS" DOCS
+14 IF ACHSGBL'="ACHSDATA"
IF (ACHSGBL'="ACHSTXDT")
Begin DoDot:2
+15 WRITE !,"CONTAINS UNRECOGNIZED DATA"
+16 WRITE !,"FACILITY CODE : '",$GET(ACHSFACD,"UNDEFINED"),"'"
+17 WRITE !,"GLOBAL NAME : '",$GET(ACHSGBL,"UNDEFINED"),"'",!
+18 DO ABEND^ACHSACOA
End DoDot:2
QUIT
+19 ;
+20 WRITE !?20,U,ACHSGBL,"( Data -- As Listed Below",!
+21 ;USE FACILITY ID READ IN FILE
SET X=$PIECE(ACHSXD2,U)
+22 ;LOOK AT AREA LOCATION FILE
SET DIC="^AUTTLOC("
+23 ;
SET DIC(0)=""
+24 ;USE THE ASUFAC X-REF
SET D="C"
+25 DO IX^DIC
+26 KILL DIC,D
+27 ;
+28 IF +Y<0
USE IO(0)
Begin DoDot:2
+29 WRITE *7,!,"FACILITY LOOK-UP ERROR ON FACILITY '",$PIECE(ACHSXD2,U,2)
+30 WRITE "', ASUFAC INDEX = '",X,"' WAS NOT FOUND IN THE 'ASUFAC' CROSS"
+31 WRITE "REFERENCE IN '^AUTTLOC LOCATION FILE'"
+32 SET IONOFF=""
DO ^%ZISC
DO ABEND^ACHSACOA
End DoDot:2
QUIT
+33 ;
+34 IF +Y>0
SET ACHSFCPT=+Y
+35 ;DATE RUN
SET ACHSDRUN=$PIECE(ACHSXD2,U,3)
+36 ;DATE OF FIRST RECORD
SET ACHSFREC=$PIECE(ACHSXD2,U,4)
+37 ;DATE OF LAST RECORD
SET ACHSLREC=$PIECE(ACHSXD2,U,5)
+38 ;NUMBER OF RECORDS
SET ACHSNRCD=$PIECE(ACHSXD2,U,7)
+39 ;STAT RECORD VERSION ;ACHS*3.1*23
SET ACHSSTV=$PIECE(ACHSXD2,U,12)
+40 ;
+41 WRITE !,"FACILITY NAME",?20,":",?25,$PIECE(ACHSXD2,U,2)
+42 WRITE !,"DATE EXPORT RUN",?20,":",?25,$$FMTE^XLFDT(ACHSDRUN)
+43 WRITE !,"DATE OF FIRST RECORD",?20,":",?25,$$FMTE^XLFDT(ACHSFREC)
+44 WRITE !,"DATE OF LAST RECORD",?20,":",?25,$$FMTE^XLFDT(ACHSLREC)
+45 WRITE !,"NUMBER OF RECORDS",?20,":",?25,ACHSNRCD,!
+46 KILL ACHSZFIF
S15F ;
+1 ;IF NO ENTRY IN THE LOG FILE CONTINUE PROCESS
+2 ;USE FACILITY PTR FROM ^AUTTLOC AND LOOK AT LOG FILE
+3 ;ACHS*3.1*21;ALLOW PROCESSING IF DEPENDING ON USER RESPONSE
+4 ;I '$D(^ACHSAOLG(ACHSFCPT,1,ACHSDRUN)) D S15X Q
+5 SET Y=1
+6 IF $DATA(^ACHSAOLG(ACHSFCPT,1,ACHSDRUN))
Begin DoDot:2
+7 USE IO(0)
+8 ; INSTITUTION NAME
+9 WRITE !!,*7,"DATA ALREADY PROCESSED FOR: ",$EXTRACT($PIECE($GET(^DIC(4,ACHSFCPT,0)),U),1,20)," EXPORT DATE OF: ",$$FMTE^XLFDT(ACHSDRUN),!!
+10 WRITE !?10,"******* ARE YOU SURE YOU WANT TO REPROCESS *******"
+11 WRITE !,"******* THIS COULD CAUSE DUPLICATE RECORDS AT UFMS AND THE FI *******",!
+12 ;I $$DIR^XBDIR("E","Enter <RETURN> to Continue Processing OR ^ TO EXIT")
+13 IF $$DIR^XBDIR("Y","Enter YES to process the file or NO to skip the file.")
End DoDot:2
+14 IF Y=1
DO S15X
QUIT
+15 ;ACHS*3.1*21 end of changes
+16 ;
+17 ;added next line - 10/5/00 - pmf
+18 ;now CLOSE the file, since we are not going to process it.
+19 DO ^%ZISC
+20 ;
End DoDot:1
+21 ;DO CONSOLIDATION REPORTS
DO REPORT^ACHSACOA
+22 ;ACHS*3.1*21
IF $$DIR^XBDIR("Y","Do you want to Continue to splitout files","Y","","","",1)
DO ^ACHSPCC1
QUIT
+23 QUIT
+24 ;
+25 ;
S15X ;
+1 ;ACHS*3.1*21
SET ^ACHSPCC("PROC")="C"
+2 DO RSLT(ACHSFACD_$JUSTIFY($$FMTE^XLFDT(ACHSDRUN),15)_$JUSTIFY("$"_$FNUMBER($PIECE(ACHSXD2,U,10),",",2),18)_$JUSTIFY("$"_$FNUMBER($PIECE(ACHSXD2,U,11),",",2),18)_$JUSTIFY("$"_$FNUMBER($PIECE(ACHSXD2,U,10)-$PIECE(ACHSXD2,U,11),",",2),18))
+3 ;
+4 ;
+5 ;AREA CONSOLIDATION (2/3) INITIALIZE COUNTERS
DO ^ACHSACO1
+6 ;MAIN PROCESSING LOOP
+7 ;
+8 ;
+9 IF $DATA(ACHSOK)
IF 'ACHSOK
DO ABEND^ACHSACOA
QUIT
+10 ;
+11 ;
+12 SET $PIECE(ACHSZFAC(ACHSFCPT,ACHSDRUN,0),U,2)=ACHSDRUN
+13 SET $PIECE(ACHSZFAC(ACHSFCPT,ACHSDRUN,0),U,3)=ACHSFREC
+14 SET $PIECE(ACHSZFAC(ACHSFCPT,ACHSDRUN,0),U,4)=ACHSLREC
+15 SET $PIECE(ACHSZFAC(ACHSFCPT,ACHSDRUN,0),U,5)=ACHSNRCD
+16 ;
+17 USE IO(0)
+18 IF $$DIR^XBDIR("E"," Press RETURN to Process NEXT FILE")
+19 QUIT
+20 ;
FDISP ;
+1 USE IO(0)
+2 WRITE @IOF,"Files available for CHS Consolidation are listed Below:"
+3 ;ACHS*3.1*19
WRITE !,"Seq",?7,"File Name",?32,"Facility Name",?53,"# Rcds",?61,"Export Date Process",!
+4 SET ACHSI=""
+5 FOR
SET ACHSI=$ORDER(ACHSLIST(ACHSI))
IF +ACHSI=0
QUIT
Begin DoDot:1
+6 SET X=ACHSLIST(ACHSI)
+7 USE IO(0)
+8 ;ACHS*3.1*19
WRITE !,$JUSTIFY(ACHSI,3),?5,$EXTRACT($PIECE(X,U,1),1,30),?32,$EXTRACT($PIECE(X,U,2),1,20),?53,$JUSTIFY($PIECE(X,U,3),6),?61,$PIECE($PIECE(X,U,4),"@")
+9 SET ACHSKJRY=X
SET ACHSKJRX=$PIECE($PIECE(X,U,1),".",2)
SET ACHSKJRX=$$JTF^ACHS(ACHSKJRX)
+10 ; Do a FM Lookup based on the ASUFAC for the file being processed
+11 SET ACHSX=ACHSKJRY
+12 DO FACLKUP
+13 IF +Y<0
USE IO(0)
WRITE *7,!,"==>FACILITY CODE LOOK-UP ERROR ON CODE '",X,"'"
QUIT
+14 SET X=ACHSKJRX
+15 KILL ACHSKJRX
+16 IF '$DATA(^ACHSAOLG(+Y,1,X,0))
DO FD2
QUIT
+17 SET Z=$PIECE($GET(^ACHSAOLG(+Y,1,X,0)),U,5)
+18 IF Z=""
SET Z=9999999
+19 SET $PIECE(ACHSLIST(ACHSI),U,5)=Z
+20 WRITE ?70,$EXTRACT(Z,4,5),"/",$EXTRACT(Z,6,7),"/",$EXTRACT(Z,2,3)
End DoDot:1
+21 QUIT
+22 ;
FD2 ;
+1 ;ACHS*3.1*19
WRITE ?75,$PIECE(ACHSLIST(ACHSI),U,5)
+2 QUIT
+3 ;
+4 ;
FACLKUP ;
+1 SET X=$EXTRACT($PIECE(ACHSX,".",1),5,10)
+2 ;
SET DIC(0)="ZM"
+3 ;AREA LOCATION FILE
SET DIC="^AUTTLOC("
+4 ;USE ASUFAC X-REF
SET D="C"
+5 DO ^DIC
+6 IF Y<1
KILL D
SET X=$PIECE(ACHSLIST(ACHSI),U,2)
DO ^DIC
+7 QUIT
+8 ;
RSLT(X) ;
+1 SET ^(0)=$GET(^TMP("ACHSACO",$JOB,0))+1
SET ^(^(0))=X
+2 QUIT
+3 ;
