- 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 ;