- 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