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

ACHSWFRS.m

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