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

ACHSACO.m

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