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

ACHSTXF.m

Go to the documentation of this file. 
  1. ACHSTXF ; IHS/OIT/FCJ - EXPORT DATA - RECORD 2(UFMS);
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,14,17**;JUN 11,2001
  1.  ;ACHS*3.1*13 IHS/OIT/FCJ NEW ROUTINE
  1.  ;This is a daily export, ending date will always be date ran unless it is a re-export.
  1.  ;
  1.  ;
  1.  D LINES^ACHSFU
  1.  W @IOF,!,ACHS("*"),!?30,"EXPORT CHS DATA FOR UFMS",!,ACHS("*"),!
  1.  S ACHSCHSS=""
  1.  D ^ACHSUF
  1.  K ACHSCHSS
  1.  D KILLGLBS^ACHSTX
  1.  S (J,ACHSDCR,ACHSBDT)=0,(ACHSPEX,ACHSRR)="",ACHSF638=$P(^ACHSF(DUZ(2),0),U,8)
  1.  S ACHSEDT=DT
  1. S1 ;Set beginning date AND ein of prev export
  1.  S ACHSBDT=$P(^ACHSF(DUZ(2),0),U,14)    ;date of last export     
  1.  S:'ACHSBDT ACHSBDT=$P(^ACHSF(DUZ(2),0),U,13)   ;date beg export to UFMS
  1.  I 'ACHSBDT G ERR
  1.  S:$D(^ACHSTXST("C",ACHSBDT,DUZ(2))) ACHSPEX=$O(^ACHSTXST("C",ACHSBDT,DUZ(2),ACHSPEX))
  1.  S ACHSBDT=ACHSBDT-1
  1.  ;
  1. S2 ;
  1.  ;Set Facility or Authorizing facility
  1.  S ACHSFDT=ACHSBDT,ACHSLDAT=ACHSEDT,ACHSAFAC=$P(^AUTTLOC(DUZ(2),0),U,10)
  1.  I $$PARM^ACHS(2,25)="Y" S X=$P(^ACHSF(DUZ(2),0),U,12) G AFACERR:+X<1 S ACHSAFAC=$P(^AUTTLOC(X,0),U,10)
  1.  I +ACHSAFAC<1 G AFACERR
  1. S3 ;Begin loop through transaction index
  1.  S ACHSBDT=$O(^ACHSF(DUZ(2),"TB",ACHSBDT))
  1.  G CVTEND1:ACHSBDT<1!(ACHSBDT>ACHSEDT)
  1.  S:ACHSRCT=0 ACHSFDT=ACHSBDT
  1.  S ACHSTY=""
  1. S4 ;skip pay documents
  1.  S ACHSTY=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY))
  1.  G S3:ACHSTY="",S4:ACHSTY="ZA"!(ACHSTY="IP")!(ACHSTY="P")
  1.  S P=0
  1. S5 ;Skip special transaction documents
  1.  S P=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY,P))
  1.  G S4:P<1,S5:$P(^ACHSF(DUZ(2),"D",P,0),U,3)=2
  1.  S (ACHSDOCR,ACHSDOCN,ACHSDOCT,ACHSIPA,ACHSDEST,ACHSCTY,ACHSDR3,ACHSTOS,ACHSDFY,X1)=""
  1.  S (ACHSXLOC,ACHSCDE,ACHSARCO,ACHSPROV,ACHSFED,ACHSEIN,ACHSDUNS,ACHSCTYP,ACHS2FY)=""
  1.  S DA=0
  1. S6 ;
  1.  S ACHSSKIP=""   ;ACHS*3.1*14 11/1/2008 IHS/OIT/FCJ
  1.  S DA=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY,P,DA))
  1.  G S5:DA<1
  1.  G S6:'$D(^ACHSF(DUZ(2),"D",P,0)) S ACHSDOCR=^(0)
  1.  G S6:'$D(^ACHSF(DUZ(2),"D",P,"T",DA,0)) S ACHSDOCT=^(0)
  1.  ;test has transaction been previously sent, because no longer based on DCR
  1.  ;ACHS*3.1*14 11/1/2008 IHS/OIT/FCJ CHANGED NXT SECTION BECAUSE NOT TESTING FOR TRANSACTION
  1.  ;I ACHSPEX,$G(^ACHSTXST(DUZ(2),1,ACHSPEX,2,"B",P,DA)) G S6
  1.  I ACHSPEX,$D(^ACHSTXST(DUZ(2),1,ACHSPEX,2,"B",P)) D
  1.  .S Y=0 F  S Y=$O(^ACHSTXST(DUZ(2),1,ACHSPEX,2,"B",P,Y)) Q:Y'?1N.N  D  Q:ACHSSKIP
  1.  ..I $P(^ACHSTXST(DUZ(2),1,ACHSPEX,2,Y,0),U,2)=DA S ACHSSKIP=1
  1.  G:ACHSSKIP S6
  1. S7 ;EP; FROM RE-EXPORT SINGLE TRANSACTIONS OR BATCHES - ACHSTXF1
  1.  S X=$P(ACHSDOCT,U,4),X=$P(X,".")_$E($P(X,".",2)_"00",1,2),ACHSIPA=$E(X+1000000000000,2,13)
  1.  S ACHSDEST=$P(ACHSDOCR,U,17),ACHSCTY=ACHSTY
  1.  I ACHSCTY="C" S ACHSCTY=$P(ACHSDOCT,U,5)  ;full or partial cancel       
  1.  S ACHSDR3=$G(^ACHSF(DUZ(2),"D",P,3),""),ACHSTOS=$P(ACHSDOCR,U,4)
  1.  S ACHSX=$P(ACHSDOCR,U,14)  ;FY SINGLE DIGIT USED IN ACHSFU RTN
  1.  S ACHSDFY=$P(ACHSDOCR,U,27),X1=$E($P(ACHSDOCR,U,27),4)  ;Four digit FY
  1.  D FYCVT^ACHSFU
  1.  S ACHSXLOC=ACHSFC   ;Area finance location code
  1.  S:ACHSY<1987 ACHSXLOC="0"_$E(ACHSFC,2,3)
  1.  S ACHSEFDT=$E(DT,4,5)_$E(DT,6,7)_$E(DT,2,3)
  1.  S ACHSCDE=$S(ACHSCTY="I":"05013",ACHSCTY="F":"05024",ACHSCTY="P":"05025",ACHSCTY="S":"05015",1:"")
  1.  S ACHSDOCN=ACHSDFY_ACHSXLOC_$P(ACHSDOCR,U)
  1.  S ACHSARCO=$P($G(^ACHSF(DUZ(2),0)),U,11)   ;AREA CONTRACTING NO.
  1.  S X=$P($G(^ACHSF(DUZ(2),"D",2)),U,9) I X S ACHSCTYP=$P($G(^ACHSCTYP(X,0)),U,2)  ;CONTRACT PURCHASE TYPE
  1.  S:$L(ACHSCTYP)=0 ACHSCTYP=" "
  1.  G ERROR^ACHSTX:ACHSCDE=""
  1.  D CANOBJ^ACHSTX8
  1.  S ACHSPROV=$P(ACHSDOCR,U,8)
  1.  S ACHSFED=$P(^AUTTVNDR(ACHSPROV,11),U,10) S:ACHSFED="" ACHSFED=" "
  1.  S ACHSEIN=$TR($P(^AUTTVNDR(ACHSPROV,11),U,13)," -,+","")
  1.  I ACHSEIN="" S ACHSEIN=$TR($P(^AUTTVNDR(ACHSPROV,11),U)_$P(^AUTTVNDR(ACHSPROV,11),U,2)," -,+","")
  1.  S X=$L(ACHSEIN) I X'=12 F I=1:1:12-X  S ACHSEIN=" "_ACHSEIN
  1.  S ACHSDUNS=$P(^AUTTVNDR(ACHSPROV,0),U,7) S X=$L(ACHSDUNS) I X'=13 F I=1:1:13-X  S ACHSDUNS=ACHSDUNS_" "
  1. S8 ;
  1.  ;ACHS*3.1*17 1.9.2010 IHS.OIT.FCJ ADDED NXT 2 LNE-SENDING BUDGET FY, 2ND LINE TEST FOR START DT BECAUSE OF DOC ALREADY SENT 
  1.  S ACHS2FY=$E(ACHSCFY,3,4)
  1.  I $P(^ACHSF(DUZ(2),0),U,16)'="",$P(ACHSDOCR,U,2)<$P(^ACHSF(DUZ(2),0),U,16) S ACHS2FY=$E(ACHSDFY,3,4)
  1.  S ACHSRCT=ACHSRCT+1         ;RECORD COUNT
  1.  S ACHSRTYP(8)=ACHSRTYP(8)+1
  1.  S ^ACHSDATA(ACHSRCT)="U2"_ACHSEFDT_ACHSCDE_$S(ACHSTOS=1:323,ACHSTOS=2:324,ACHSTOS=3:325,1:"")_"HHSI"_ACHSARCO_ACHSDOCN_ACHSCTYP_$J("",3)_"1"_X1
  1.  ;ACHS*3.1*17 1.9.2010 IHS.OIT.FCJ MOD NXT LINE TO SEND BUD FY
  1.  ;S ^ACHSDATA(ACHSRCT)=^ACHSDATA(ACHSRCT)_ACHSCAN_ACHSOBJC_ACHSIPA_ACHSFED_ACHSEIN_$J("",54)_$E(ACHSDFY,3,4)_ACHSDEST_" "_ACHSXLOC_ACHSDUNS_$J("",10)
  1.  S ^ACHSDATA(ACHSRCT)=^ACHSDATA(ACHSRCT)_ACHSCAN_ACHSOBJC_ACHSIPA_ACHSFED_ACHSEIN_$J("",54)_ACHS2FY_ACHSDEST_" "_ACHSXLOC_ACHSDUNS_$J("",10)
  1.  ;
  1.  I $L(^ACHSDATA(ACHSRCT))'=161 W !!,*7,*7,"A DHR RECORD WAS PRODUCED THAT WAS NOT 161 CHARACTERS IN LENGTH:",!!,^(ACHSRCT),!,*7,*7 G ERROR^ACHSTX
  1.  I ACHSRCT=1 S ACHSFDT=ACHSBDT W !!,"NUMBER OF RECORDS PROCESSED = ",!!
  1.  I ACHSRCT#25=0 W $J(ACHSRCT,8)
  1.  I ACHSDEST="F" D
  1.  .I +$P(ACHSDOCR,U,22),+$P(ACHSDOCR,U,20),+$P(ACHSDOCR,U,21) S ^ACHSTXPT(+$P(ACHSDOCR,U,22),+$P(ACHSDOCR,U,20),+$P(ACHSDOCR,U,21))=ACHSDEST ;SET REC FOR PT REC
  1.  .S ^ACHSTXVN(ACHSPROV)=ACHSDEST   ;VENDOR DATA
  1.  .S ^ACHSTXOB(P,DA)=""   ;DOC INFO FOR FI
  1.  S ^TMP("ACHSTX",$J,P,DA)=""
  1.  I ACHSF638="Y",$$PARM^ACHS(2,9)="Y",'$P(ACHSDOCR,U,3) S ^ACHSTXPG(ACHSTOS,P,DA)="" ;STATISTICAL
  1.  S:ACHSTY="P"&(ACHSDEST'="F") ^ACHSTXPD(P,DA)=""  ;AREA OFFICE DATA
  1.  Q:ACHSREEX  ;ACHS*3.1*14 11/1/2008 IHS/OIT/FCJ TEST FOR REEXPORT
  1.  G S6
  1.  ;
  1. ERR ;
  1.  W !!,*7,*7,"ERROR THE UFMS EXPORT START DATE MUST BE ENTERED IN THE CHS PARAMETERS"
  1.  D ^%ZISC,KILL^ACHSTX8,RTRN^ACHS
  1.  Q
  1.  ;
  1. AFACERR ;
  1.  W !!,*7,*7,"AUTHORIZING FACILITY CODE ERROR  -  JOB CANCELLED"
  1.  D ^%ZISC,KILL^ACHSTX8
  1.  Q
  1.  ;
  1. CVTEND1 ;
  1.  W $J(ACHSRCT,8)
  1.  S ACHSROUT=ACHSRCT
  1.  S:ACHSRCT>2 ACHSROUT=ACHSRCT
  1.  K ACHSX,ACHSDUNS,X1,ACHSDFY,ACHSXLOC,ACHSCTYP,ACHSFED,ACHSOBJC,ACHSTOS,DA,ACHSTY,ACHSEIN,ACHSSKIP,ACHS2FY
  1.  K ACHSDEST,ACHSDCR,ACHSF638,ACHSIPA,ACHSCAN,ACHSCDE,ACHSCTY,ACHSDOCN,ACHSDOCR,ACHSDR3,ACHSDOCT,ACHSEFDT,ACHSPROV
  1.  G ^ACHSTX3
  1.  Q
  1.  ;
  1. SET(%) ;
  1.  S %=%_$J("",80-$L(%))
  1.  S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)=%
  1.  I ACHSRCT#25=0 W $J(ACHSRCT,8)
  1.  Q
  1.  ;