ACHSWFRS ;IHS/OIT/LMH - WEBFRS EXTRACT DATA ; 17 Jul 2008 3:03 PM
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,15**;JUN 11,2001
;WEBFRS DATA EXTRACT ORIGINAL ROUTINE FROM KEVIN ROGERS
;ACHS*3.1*14 IHS/OIT/LMH Modified to bring into ACHS namespace
;ACHS*3.1*14 IHS/OIT/FCJ Added DCIS section; removed Dev section; removed all IO writes and
; un used lines of code; changed DUZ(2) to ACHSFAC; modified Sendto section
;ACHS*3.1*15 IHS/OIT/FCJ Added test for Error checks for DCIS records, call for dev to print report,
; multiple changes throughout routine to test for printing error report
;NOTE: Routine is scheduled through taskman, do not write to screen, unless the ZTQUEUED variable is tested
;
S ACHSFLG1=""
ST ;EP FOR REPORT ONLY
;--- Set the current patch version variable ---
K ACHSVER S ACHSVER="P"_15 ;PATCH VERIFICATION FOR CONSOLIDATION PROCESS
;ACHS*3.1*15 2.13.2009 IHS/OIT/FCJ ADDED ^TMP($J,"ACHSWERR") TO NXT LINE
K ^TMP($J,"ACHSWREC"),^TMP($J,"ACHSWFRS"),^TMP($J,"ACHSWERR")
S ^TMP($J,"ACHSWERR",0)=0 ;ACHS*3.1*15 2.13.2009 IHS/OIT/FCJ ADDED LINE
D ^ACHSVAR
;ACHS*3.1*15 2.17.2009 IHS/OIT/FCJ added REP section
REP ;
I ACHSFLG1=1 D G:POP KILL2
.W @IOF,!!,$$C^ACHS("DCIS ERROR REPORT")
.W !!,"NOTE: Documents will not be sent to DCIS until errors are fixed",!
.D ^%ZIS ;EXIT BY "^" POP=1
.Q:POP ;EXIT OUT OF %ZIS
.I $D(IO("S")) D SLV^ACHSFU ;IF SLAVE DEV, DO OPEN & GET CLOSE PARAMS
;
;---- Loop CHS facilities -----------------------------------------
;---- Do not process facilities with incomplete configurations
;---- Do not process inactive facilities
;---- Process IHS & CHS affiliated locations ONLY;IHS/OCA/KJR;19DEC03
;---- Get export path from RPMS SITE file
;
S ACHSFAC=0
F S ACHSFAC=$O(^ACHSF(ACHSFAC)) Q:'ACHSFAC D
.I ACHSFLG1=1,DUZ(2)'=ACHSFAC Q
.Q:'$D(^ACHSF(ACHSFAC,2)) ;FACILITY PARAMETERS NOT SET
.Q:$L($P(^AUTTLOC(ACHSFAC,0),"^",17))'=3 ;FINANCE CODE NOT SET
.Q:'$G(^ACHS(9,ACHSFAC,"FY",ACHSCFY,0)) ;NO CURRENT YEAR ACTIVITY
.;
.;---- Begin: Check Affiliation ----
.;
.K DA,ACHSTMP S ACHSAFF=0,ACHSTMP(9999999)=0,DA=0
.F S DA=$O(^AUTTLOC(ACHSFAC,11,DA)) Q:'DA D
..Q:$D(^AUTTLOC(ACHSFAC,11,DA,0))'=1 S ACHS0=^(0)
..F J=1:1:3 S ACHSP="ACHSP"_J,@ACHSP=$P(ACHS0,"^",J)
..Q:ACHSP2&(ACHSP2<DT) Q:ACHSP1&(ACHSP1>DT)
..S ACHSTMP(9999999-ACHSP1)=ACHSP3
.S DA=$O(ACHSTMP("")) S:DA<9999999 ACHSAFF=ACHSTMP(DA)
.K DA,ACHSTMP,ACHS0,J,ACHSP,ACHSP1,ACHSP2,ACHSP3
.Q:ACHSAFF'=1&(ACHSAFF'=3) ;USE IHS & CHS AFFILIATED SITES ONLY
.;
.;---- End: Check Affiliation ---
.;
.S DFN=$O(^AUTTSITE(0)) Q:'DFN ;NO RPMS SITE SET
.Q:$D(^AUTTSITE(DFN,1))'=1 S ACHSPUB=$P(^(1),"^",2)
.Q:ACHSPUB']"" ;NO FILE EXPORT PATH DEFINED
.D START
.D:ACHSFLG1="" SENDFILE
.I ACHSFLG1=1 X:$D(IO("S")) ACHSPPO D RPT^ACHSWDR ;ACHS*3.1*15 2.13.2009 IHS/OIT/FCJ RUN ERROR REPORT
.K ^TMP($J,"ACHSWREC"),^TMP($J,"ACHSWFRS"),^TMP($J,"ACHSWERR") ;;ACHS*3.1*15 2.13.2009 IHS/OIT/FCJ ADD ACHSWERR NODE
D KILL2
X:$D(IO("S")) ACHSPPC
D:IO'=IO(0) ^%ZISC
K ACHSQ,ACHSPPC,ACHSPPO
Q
;
START ;
S ASUFAC=$P(^AUTTLOC(ACHSFAC,0),"^",10)
F ACHSFYS=2:-1:0 S ACHSFY=ACHSCFY-ACHSFYS D ;Loop thru last 2 years of documents
.D ^ACHSVAR
.D FYSEL
.D PRINT
Q
;
FYSEL ; Identify fiscal years for data export
S ACHSWFY=ACHSFY
S %=$$FY^ACHSVAR($E(ACHSFY,3,4)),ACHSBDT=$P(%,U),ACHSEDT=$P(%,U,2)
I ACHSEDT>DT S ACHSEDT=DT
;
;
REM ; --- Remove the intended Host File ---
Q:ACHSFLG1=1
I ACHSWFY=(ACHSCFY-2) D
.S ACHSCMD=ACHSPUB_"chs"_ASUFAC_".txt"
.I $$VERSION^%ZOSV(1)["UNIX" S ACHSCMD="rm "_ACHSCMD
.E S ACHSCMD="del "_ACHSCMD
.S ACHSX=$$JOBWAIT^%HOSTCMD(ACHSCMD)
Q
;
;
PRINT ;
S ACHSFC=$P($G(^AUTTAREA($P($G(^AUTTLOC(ACHSFAC,0)),U,4),0)),U,3)_$E($P($G(^AUTTLOC(ACHSFAC,0)),U,17),2,3)
I $D(ACHSERR),ACHSERR=1 K ZTSK D KILL Q
S (ACHSTOTP,ACHSCNX,ACHSOPEN,ACHSTOTP("$"),ACHSCNX("$"),ACHSOPEN("$"))=0
S X3=0,ACHSDNU=1_($E(ACHSWFY,4))_"00000"
A ; Main loop. Check end date.
S ACHSDNU=$O(^ACHSF(ACHSFAC,"D","B",ACHSDNU))
I (ACHSDNU="")!($E(ACHSDNU,2)'=$E(ACHSWFY,4)) D KILL Q
S ACHSDIEN="" F I=1:1:9 S ACHSERR(I)=""
B ; Get IEN.
S ACHSDIEN=$O(^ACHSF(ACHSFAC,"D","B",ACHSDNU,ACHSDIEN))
G A:ACHSDIEN=""
C ;
G A:'$D(^ACHSF(ACHSFAC,"D",ACHSDIEN,0)) S ACHSSTS=$S($P(^(0),U,12)=3:"P",$P(^(0),U,12)=4:"C",1:"OPEN")
S ACHSDOC1=$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U),ACHSVDFN=$P(^(0),U,8),ACHSDOC2=$P(^(0),U,14),ACHSDFY=$P(^(0),U,27),ACHSOBJ=$P(^(0),U,7)
S ACHS("$")=$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,9),ACHSTOS=$P(^(0),U,4),ACHSBLNK=+$P(^(0),U,3),ACHSORDT=$P(^(0),U,2),ACHS("$PCAN")=0
G B:ACHSVDFN']"",B:'$D(^AUTTVNDR(ACHSVDFN,0)) S ACHSVNDR=$P(^(0),U) S ACHSEIN="" S:$D(^(11)) ACHSEIN=$P(^(11),U)_" "_$P(^(11),U,2)
S ACHSDOC=ACHSDOC2_"-"_ACHSFC_"-"_ACHSDOC1
K ACHSNAME
S DFN=$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,22)
I +DFN>0,$D(^DPT(DFN,0)) S ACHSNAME=$P(^(0),U)
I '$D(ACHSNAME),ACHSBLNK S ACHSNAME=$S(ACHSBLNK=1:"* BLANKET",1:"* SPECIAL TRANS")
G B:'$D(ACHSNAME)
S:$D(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA")) ACHS("$")=+^("PA")
S:$D(^ACHSF(ACHSFAC,"D",ACHSDIEN,"ZA")) ACHS("$")=+^("ZA")
F ACHS=0:0 S ACHS=$O(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",ACHS)) Q:+ACHS=0 D
. S ACHSDOS=$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",ACHS,0),U,10)
. I $P(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",ACHS,0),U,2)="C",$P(^(0),U,5)="F" S ACHS("$")=$P(^(0),U,4)
. I $P(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",ACHS,0),U,2)="C",$P(^(0),U,5)="P" S ACHS("$PCAN")=ACHS("$PCAN")+$P(^(0),U,4)
.Q
;
; --- Create delimited text record here ---
;
; --- Add doc num and dollar totals ---
S ACHSDOC=0_$P(ACHSDOC,"-")_$P(ACHSDOC,"-",2)_$P(ACHSDOC,"-",3)
G:$D(^TMP($J,"ACHSWFRS",ACHSDOC))=1 B ; STOP IF DUPLICATE DOCUMENT
S ^TMP($J,"ACHSWFRS",ACHSDOC)=""
I ACHSSTS="P" S ACHSTOT=ACHS("$")_U_ACHS("$")
I ACHSSTS="C" S ACHSTOT="0^0"
I ACHSSTS'="P" I ACHSSTS'="C" S ACHSTOT=ACHS("$")_"^0"
;
; --- Add the Pseudo Prefix ---
S ACHSPSD="" I $D(^AUTTLOC(ACHSFAC,1))=1 S ACHSPSD=$P(^(1),"^",2)
;
; --- Add the vendor data ---
S ACHSVDFN=$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,8)
K ACHSDATA S ACHSDATA="^^^^^^^^^^^^^^^^^^^^^"
I +ACHSVDFN D ^ACHSWVEN
;
; --- Add the CAN letter indicator ---
S ACHSCAN=$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),"^",6),ACHSFYI=""
I ACHSCAN,$D(^ACHS(2,+ACHSCAN,0)) S ACHSFYI=$E($P(^(0),"^"),5)
;
; --- Add the document destination indicator ---
S ACHSDEST=$P(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,17)
;
;ACHS*3.1*14 IHS/OIT/FCJ Added DCIS section
DCIS ; ----DCIS SECTION ---
S ACHSREC="^^^^^^^^^^^^^^^^^^^"
;FOR TESTING UNCOMMENT NXT LINE AND COMMENT OUT SECOND LINE
;I ACHSSTS="P" D DCIS^ACHSWDCS
I ACHSORDT>3081000,ACHSDFY>2007,ACHSSTS="P" D DCIS^ACHSWDCS
;
; --- Write line feed/return to top of loop ---
S ^TMP($J,"ACHSWREC",ACHSDOC)=ACHSDOC_U_ACHSTOT_U_ACHSPSD_U_ACHSDATA_U_ACHSFYI_U_ACHSDEST_U_ACHSVER_ACHSREC
G B
;
; --- End of new code here ---
;
;BEGIN NEW CODE IHS/OIT/LMH
SENDFILE ; Send file
N X1,XBCON,XBE,XBF,XBQ,XBQSHO,XBFN,XBGL,XBFLT,XBMED,XBS1
S XBFN="chs"_ASUFAC_".txt"
S XBGL="TMP("_$J_",""ACHSWREC"","
S XBQSHO=""
S XBF=$J
S XBE=$J
S XBFLT=1
S XBMED="F"
S XBCON=1
S XBS1="ACHS WEBFRS B"
S XBQ="N"
D ^XBGSAVE
Q
;END NEW CODE IHS/OIT/LMH
KILL ; Do ERPT, kill vars, quit
K ACHSDNU,ACHSDOC,ACHSDOC1,ACHSDOC2,ACHSBLNK,ACHSCNX,ACHSDOS,ACHSVNDR,ACHSEIN
K ACHSSTS,ACHSTOS,ACHSTOTP,ACHSVDFN,ACHSDIEN,DFN,X2,X3,ACHSOPEN,ACHSNAME
K ACHSBDT,ACHSCMD,ACHSORDT,ACHSEDT,ACHSERR,ACHSACFY,ACHSERR,ACHSFC
K ACHSTOT,ACHSWFY,DA,ZISHC,ZISHDA1,ACHS13,ACHSFYDT,ACHSFYWK
K ACHSCAN,ACHSDATA,ACHSDOC,ACHSFILE,ACHSFYI,ACHSPSD,ACHSDFY,ACHSOBJ
K ACHSPUB,ACHSFAX,ACHSVDFN,ACHSAFF,ACHSDEST
K ACHSRTYP,ACHSCTYP,ACHSCDFN,ACHSVC,ACHSVCL,X,ACHSTST,ACHSREC
Q
KILL2 ;
K I,C,ACHSFYS,ACHSVER,ACHSFAC
K ACHS,ACHSACFY,ACHSBM,ACHSCNU,ACHSFLG,ACHSLN,ACHSLOC,ACHSPG,ACHSPIID,ACHSTIME,ACHSUSR
K ACHSVFAX,ASUFAC,X,X1,ACHSFLG1
I '$D(ZTQUEUED) D ^ACHSVAR
Q
ACHSWFRS ;IHS/OIT/LMH - WEBFRS EXTRACT DATA ; 17 Jul 2008 3:03 PM
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,15**;JUN 11,2001
+2 ;WEBFRS DATA EXTRACT ORIGINAL ROUTINE FROM KEVIN ROGERS
+3 ;ACHS*3.1*14 IHS/OIT/LMH Modified to bring into ACHS namespace
+4 ;ACHS*3.1*14 IHS/OIT/FCJ Added DCIS section; removed Dev section; removed all IO writes and
+5 ; un used lines of code; changed DUZ(2) to ACHSFAC; modified Sendto section
+6 ;ACHS*3.1*15 IHS/OIT/FCJ Added test for Error checks for DCIS records, call for dev to print report,
+7 ; multiple changes throughout routine to test for printing error report
+8 ;NOTE: Routine is scheduled through taskman, do not write to screen, unless the ZTQUEUED variable is tested
+9 ;
+10 SET ACHSFLG1=""
ST ;EP FOR REPORT ONLY
+1 ;--- Set the current patch version variable ---
+2 ;PATCH VERIFICATION FOR CONSOLIDATION PROCESS
KILL ACHSVER
SET ACHSVER="P"_15
+3 ;ACHS*3.1*15 2.13.2009 IHS/OIT/FCJ ADDED ^TMP($J,"ACHSWERR") TO NXT LINE
+4 KILL ^TMP($JOB,"ACHSWREC"),^TMP($JOB,"ACHSWFRS"),^TMP($JOB,"ACHSWERR")
+5 ;ACHS*3.1*15 2.13.2009 IHS/OIT/FCJ ADDED LINE
SET ^TMP($JOB,"ACHSWERR",0)=0
+6 DO ^ACHSVAR
+7 ;ACHS*3.1*15 2.17.2009 IHS/OIT/FCJ added REP section
REP ;
+1 IF ACHSFLG1=1
Begin DoDot:1
+2 WRITE @IOF,!!,$$C^ACHS("DCIS ERROR REPORT")
+3 WRITE !!,"NOTE: Documents will not be sent to DCIS until errors are fixed",!
+4 ;EXIT BY "^" POP=1
DO ^%ZIS
+5 ;EXIT OUT OF %ZIS
IF POP
QUIT
+6 ;IF SLAVE DEV, DO OPEN & GET CLOSE PARAMS
IF $DATA(IO("S"))
DO SLV^ACHSFU
End DoDot:1
IF POP
GOTO KILL2
+7 ;
+8 ;---- Loop CHS facilities -----------------------------------------
+9 ;---- Do not process facilities with incomplete configurations
+10 ;---- Do not process inactive facilities
+11 ;---- Process IHS & CHS affiliated locations ONLY;IHS/OCA/KJR;19DEC03
+12 ;---- Get export path from RPMS SITE file
+13 ;
+14 SET ACHSFAC=0
+15 FOR
SET ACHSFAC=$ORDER(^ACHSF(ACHSFAC))
IF 'ACHSFAC
QUIT
Begin DoDot:1
+16 IF ACHSFLG1=1
IF DUZ(2)'=ACHSFAC
QUIT
+17 ;FACILITY PARAMETERS NOT SET
IF '$DATA(^ACHSF(ACHSFAC,2))
QUIT
+18 ;FINANCE CODE NOT SET
IF $LENGTH($PIECE(^AUTTLOC(ACHSFAC,0),"^",17))'=3
QUIT
+19 ;NO CURRENT YEAR ACTIVITY
IF '$GET(^ACHS(9,ACHSFAC,"FY",ACHSCFY,0))
QUIT
+20 ;
+21 ;---- Begin: Check Affiliation ----
+22 ;
+23 KILL DA,ACHSTMP
SET ACHSAFF=0
SET ACHSTMP(9999999)=0
SET DA=0
+24 FOR
SET DA=$ORDER(^AUTTLOC(ACHSFAC,11,DA))
IF 'DA
QUIT
Begin DoDot:2
+25 IF $DATA(^AUTTLOC(ACHSFAC,11,DA,0))'=1
QUIT
SET ACHS0=^(0)
+26 FOR J=1:1:3
SET ACHSP="ACHSP"_J
SET @ACHSP=$PIECE(ACHS0,"^",J)
+27 IF ACHSP2&(ACHSP2<DT)
QUIT
IF ACHSP1&(ACHSP1>DT)
QUIT
+28 SET ACHSTMP(9999999-ACHSP1)=ACHSP3
End DoDot:2
+29 SET DA=$ORDER(ACHSTMP(""))
IF DA<9999999
SET ACHSAFF=ACHSTMP(DA)
+30 KILL DA,ACHSTMP,ACHS0,J,ACHSP,ACHSP1,ACHSP2,ACHSP3
+31 ;USE IHS & CHS AFFILIATED SITES ONLY
IF ACHSAFF'=1&(ACHSAFF'=3)
QUIT
+32 ;
+33 ;---- End: Check Affiliation ---
+34 ;
+35 ;NO RPMS SITE SET
SET DFN=$ORDER(^AUTTSITE(0))
IF 'DFN
QUIT
+36 IF $DATA(^AUTTSITE(DFN,1))'=1
QUIT
SET ACHSPUB=$PIECE(^(1),"^",2)
+37 ;NO FILE EXPORT PATH DEFINED
IF ACHSPUB']""
QUIT
+38 DO START
+39 IF ACHSFLG1=""
DO SENDFILE
+40 ;ACHS*3.1*15 2.13.2009 IHS/OIT/FCJ RUN ERROR REPORT
IF ACHSFLG1=1
IF $DATA(IO("S"))
XECUTE ACHSPPO
DO RPT^ACHSWDR
+41 ;;ACHS*3.1*15 2.13.2009 IHS/OIT/FCJ ADD ACHSWERR NODE
KILL ^TMP($JOB,"ACHSWREC"),^TMP($JOB,"ACHSWFRS"),^TMP($JOB,"ACHSWERR")
End DoDot:1
+42 DO KILL2
+43 IF $DATA(IO("S"))
XECUTE ACHSPPC
+44 IF IO'=IO(0)
DO ^%ZISC
+45 KILL ACHSQ,ACHSPPC,ACHSPPO
+46 QUIT
+47 ;
START ;
+1 SET ASUFAC=$PIECE(^AUTTLOC(ACHSFAC,0),"^",10)
+2 ;Loop thru last 2 years of documents
FOR ACHSFYS=2:-1:0
SET ACHSFY=ACHSCFY-ACHSFYS
Begin DoDot:1
+3 DO ^ACHSVAR
+4 DO FYSEL
+5 DO PRINT
End DoDot:1
+6 QUIT
+7 ;
FYSEL ; Identify fiscal years for data export
+1 SET ACHSWFY=ACHSFY
+2 SET %=$$FY^ACHSVAR($EXTRACT(ACHSFY,3,4))
SET ACHSBDT=$PIECE(%,U)
SET ACHSEDT=$PIECE(%,U,2)
+3 IF ACHSEDT>DT
SET ACHSEDT=DT
+4 ;
+5 ;
REM ; --- Remove the intended Host File ---
+1 IF ACHSFLG1=1
QUIT
+2 IF ACHSWFY=(ACHSCFY-2)
Begin DoDot:1
+3 SET ACHSCMD=ACHSPUB_"chs"_ASUFAC_".txt"
+4 IF $$VERSION^%ZOSV(1)["UNIX"
SET ACHSCMD="rm "_ACHSCMD
+5 IF '$TEST
SET ACHSCMD="del "_ACHSCMD
+6 SET ACHSX=$$JOBWAIT^%HOSTCMD(ACHSCMD)
End DoDot:1
+7 QUIT
+8 ;
+9 ;
PRINT ;
+1 SET ACHSFC=$PIECE($GET(^AUTTAREA($PIECE($GET(^AUTTLOC(ACHSFAC,0)),U,4),0)),U,3)_$EXTRACT($PIECE($GET(^AUTTLOC(ACHSFAC,0)),U,17),2,3)
+2 IF $DATA(ACHSERR)
IF ACHSERR=1
KILL ZTSK
DO KILL
QUIT
+3 SET (ACHSTOTP,ACHSCNX,ACHSOPEN,ACHSTOTP("$"),ACHSCNX("$"),ACHSOPEN("$"))=0
+4 SET X3=0
SET ACHSDNU=1_($EXTRACT(ACHSWFY,4))_"00000"
A ; Main loop. Check end date.
+1 SET ACHSDNU=$ORDER(^ACHSF(ACHSFAC,"D","B",ACHSDNU))
+2 IF (ACHSDNU="")!($EXTRACT(ACHSDNU,2)'=$EXTRACT(ACHSWFY,4))
DO KILL
QUIT
+3 SET ACHSDIEN=""
FOR I=1:1:9
SET ACHSERR(I)=""
B ; Get IEN.
+1 SET ACHSDIEN=$ORDER(^ACHSF(ACHSFAC,"D","B",ACHSDNU,ACHSDIEN))
+2 IF ACHSDIEN=""
GOTO A
C ;
+1 IF '$DATA(^ACHSF(ACHSFAC,"D",ACHSDIEN,0))
GOTO A
SET ACHSSTS=$SELECT($PIECE(^(0),U,12)=3:"P",$PIECE(^(0),U,12)=4:"C",1:"OPEN")
+2 SET ACHSDOC1=$PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U)
SET ACHSVDFN=$PIECE(^(0),U,8)
SET ACHSDOC2=$PIECE(^(0),U,14)
SET ACHSDFY=$PIECE(^(0),U,27)
SET ACHSOBJ=$PIECE(^(0),U,7)
+3 SET ACHS("$")=$PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,9)
SET ACHSTOS=$PIECE(^(0),U,4)
SET ACHSBLNK=+$PIECE(^(0),U,3)
SET ACHSORDT=$PIECE(^(0),U,2)
SET ACHS("$PCAN")=0
+4 IF ACHSVDFN']""
GOTO B
IF '$DATA(^AUTTVNDR(ACHSVDFN,0))
GOTO B
SET ACHSVNDR=$PIECE(^(0),U)
SET ACHSEIN=""
IF $DATA(^(11))
SET ACHSEIN=$PIECE(^(11),U)_" "_$PIECE(^(11),U,2)
+5 SET ACHSDOC=ACHSDOC2_"-"_ACHSFC_"-"_ACHSDOC1
+6 KILL ACHSNAME
+7 SET DFN=$PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,22)
+8 IF +DFN>0
IF $DATA(^DPT(DFN,0))
SET ACHSNAME=$PIECE(^(0),U)
+9 IF '$DATA(ACHSNAME)
IF ACHSBLNK
SET ACHSNAME=$SELECT(ACHSBLNK=1:"* BLANKET",1:"* SPECIAL TRANS")
+10 IF '$DATA(ACHSNAME)
GOTO B
+11 IF $DATA(^ACHSF(ACHSFAC,"D",ACHSDIEN,"PA"))
SET ACHS("$")=+^("PA")
+12 IF $DATA(^ACHSF(ACHSFAC,"D",ACHSDIEN,"ZA"))
SET ACHS("$")=+^("ZA")
+13 FOR ACHS=0:0
SET ACHS=$ORDER(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",ACHS))
IF +ACHS=0
QUIT
Begin DoDot:1
+14 SET ACHSDOS=$PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",ACHS,0),U,10)
+15 IF $PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",ACHS,0),U,2)="C"
IF $PIECE(^(0),U,5)="F"
SET ACHS("$")=$PIECE(^(0),U,4)
+16 IF $PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,"T",ACHS,0),U,2)="C"
IF $PIECE(^(0),U,5)="P"
SET ACHS("$PCAN")=ACHS("$PCAN")+$PIECE(^(0),U,4)
+17 QUIT
End DoDot:1
+18 ;
+19 ; --- Create delimited text record here ---
+20 ;
+21 ; --- Add doc num and dollar totals ---
+22 SET ACHSDOC=0_$PIECE(ACHSDOC,"-")_$PIECE(ACHSDOC,"-",2)_$PIECE(ACHSDOC,"-",3)
+23 ; STOP IF DUPLICATE DOCUMENT
IF $DATA(^TMP($JOB,"ACHSWFRS",ACHSDOC))=1
GOTO B
+24 SET ^TMP($JOB,"ACHSWFRS",ACHSDOC)=""
+25 IF ACHSSTS="P"
SET ACHSTOT=ACHS("$")_U_ACHS("$")
+26 IF ACHSSTS="C"
SET ACHSTOT="0^0"
+27 IF ACHSSTS'="P"
IF ACHSSTS'="C"
SET ACHSTOT=ACHS("$")_"^0"
+28 ;
+29 ; --- Add the Pseudo Prefix ---
+30 SET ACHSPSD=""
IF $DATA(^AUTTLOC(ACHSFAC,1))=1
SET ACHSPSD=$PIECE(^(1),"^",2)
+31 ;
+32 ; --- Add the vendor data ---
+33 SET ACHSVDFN=$PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,8)
+34 KILL ACHSDATA
SET ACHSDATA="^^^^^^^^^^^^^^^^^^^^^"
+35 IF +ACHSVDFN
DO ^ACHSWVEN
+36 ;
+37 ; --- Add the CAN letter indicator ---
+38 SET ACHSCAN=$PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),"^",6)
SET ACHSFYI=""
+39 IF ACHSCAN
IF $DATA(^ACHS(2,+ACHSCAN,0))
SET ACHSFYI=$EXTRACT($PIECE(^(0),"^"),5)
+40 ;
+41 ; --- Add the document destination indicator ---
+42 SET ACHSDEST=$PIECE(^ACHSF(ACHSFAC,"D",ACHSDIEN,0),U,17)
+43 ;
+44 ;ACHS*3.1*14 IHS/OIT/FCJ Added DCIS section
DCIS ; ----DCIS SECTION ---
+1 SET ACHSREC="^^^^^^^^^^^^^^^^^^^"
+2 ;FOR TESTING UNCOMMENT NXT LINE AND COMMENT OUT SECOND LINE
+3 ;I ACHSSTS="P" D DCIS^ACHSWDCS
+4 IF ACHSORDT>3081000
IF ACHSDFY>2007
IF ACHSSTS="P"
DO DCIS^ACHSWDCS
+5 ;
+6 ; --- Write line feed/return to top of loop ---
+7 SET ^TMP($JOB,"ACHSWREC",ACHSDOC)=ACHSDOC_U_ACHSTOT_U_ACHSPSD_U_ACHSDATA_U_ACHSFYI_U_ACHSDEST_U_ACHSVER_ACHSREC
+8 GOTO B
+9 ;
+10 ; --- End of new code here ---
+11 ;
+12 ;BEGIN NEW CODE IHS/OIT/LMH
SENDFILE ; Send file
+1 NEW X1,XBCON,XBE,XBF,XBQ,XBQSHO,XBFN,XBGL,XBFLT,XBMED,XBS1
+2 SET XBFN="chs"_ASUFAC_".txt"
+3 SET XBGL="TMP("_$JOB_",""ACHSWREC"","
+4 SET XBQSHO=""
+5 SET XBF=$JOB
+6 SET XBE=$JOB
+7 SET XBFLT=1
+8 SET XBMED="F"
+9 SET XBCON=1
+10 SET XBS1="ACHS WEBFRS B"
+11 SET XBQ="N"
+12 DO ^XBGSAVE
+13 QUIT
+14 ;END NEW CODE IHS/OIT/LMH
KILL ; Do ERPT, kill vars, quit
+1 KILL ACHSDNU,ACHSDOC,ACHSDOC1,ACHSDOC2,ACHSBLNK,ACHSCNX,ACHSDOS,ACHSVNDR,ACHSEIN
+2 KILL ACHSSTS,ACHSTOS,ACHSTOTP,ACHSVDFN,ACHSDIEN,DFN,X2,X3,ACHSOPEN,ACHSNAME
+3 KILL ACHSBDT,ACHSCMD,ACHSORDT,ACHSEDT,ACHSERR,ACHSACFY,ACHSERR,ACHSFC
+4 KILL ACHSTOT,ACHSWFY,DA,ZISHC,ZISHDA1,ACHS13,ACHSFYDT,ACHSFYWK
+5 KILL ACHSCAN,ACHSDATA,ACHSDOC,ACHSFILE,ACHSFYI,ACHSPSD,ACHSDFY,ACHSOBJ
+6 KILL ACHSPUB,ACHSFAX,ACHSVDFN,ACHSAFF,ACHSDEST
+7 KILL ACHSRTYP,ACHSCTYP,ACHSCDFN,ACHSVC,ACHSVCL,X,ACHSTST,ACHSREC
+8 QUIT
KILL2 ;
+1 KILL I,C,ACHSFYS,ACHSVER,ACHSFAC
+2 KILL ACHS,ACHSACFY,ACHSBM,ACHSCNU,ACHSFLG,ACHSLN,ACHSLOC,ACHSPG,ACHSPIID,ACHSTIME,ACHSUSR
+3 KILL ACHSVFAX,ASUFAC,X,X1,ACHSFLG1
+4 IF '$DATA(ZTQUEUED)
DO ^ACHSVAR
+5 QUIT
