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

ACHSTX2.m

Go to the documentation of this file. 
  1. ACHSTX2 ; IHS/ITSC/PMF - EXPORT DATA (3/9) - RECORD 2(DHR), SET GLOBALS FOR OTHER RECORD TYPES ;JUL 10, 2008
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,13,14,15,16,22**;JUN 11,2001;Build 43
  1.  ;ITSC/SET/JVK 10-29-03 ACHS*3.1*7 - TEST FOR E-SIG ON EXPORT
  1.  ;ACHS*3.1*13 6.13.2007 IHS/OIT/FCJ ADDED REC CNT FOR UFMS and also create UFMS record for live testing
  1.  ;ACHS*3.1*14 8.31.2007 IHS/OIT/FCJ Fixed Tribal Stat records: Only Pay Documents and only if parameter is set
  1.  ;
  1.  ;  This routine was used to create routine ACHSTXA1, which is used in
  1.  ;  creation of DHR records for specifically selected document
  1.  ;  transactions.  If any change is made to the logic in this routine,
  1.  ;  the same logic change should be made to ACHSTXA1.
  1.  ;
  1.  D LINES^ACHSFU
  1.  W @IOF,!,ACHS("*"),!?30,"EXPORT CHS DATA",!,ACHS("*"),!
  1.  S ACHSCHSS=""
  1.  D ^ACHSUF
  1.  K ACHSCHSS
  1.  D KILLGLBS^ACHSTX
  1.  S (J,ACHSDCR,ACHSEDT,ACHSBDT)=0,ACHSRR="",ACHSF638=$P(^ACHSF(DUZ(2),0),U,8)
  1.  ;F ACHS=2:1:7 S ACHSRTYP(ACHS)=0
  1.  F ACHS=2:1:8 S ACHSRTYP(ACHS)=0  ;ACHS*3.1*13 6.13.2007 IHS/OIT/FCJ ADDED RECORD COUNT 8 FOR UFMS
  1.  I '$D(^ACHSTXST(DUZ(2))) S DA=9999998-DT G S1
  1.  F I=1:1 S J=$O(^ACHSTXST(DUZ(2),1,J)) Q:+J<1  S P=J
  1.  S ACHSBDT=$P(^ACHSTXST(DUZ(2),1,P,0),U,3),N=9999998-DT,DA=N
  1.  S DA=DA-1
  1. S1 ;
  1.  S DA=$O(^ACHS(9,DUZ(2),"FY",ACHSCFY,"AR",DA))
  1.  G S2:DA<1
  1. S11 ;
  1.  S ACHSDCR=$O(^ACHS(9,DUZ(2),"FY",ACHSCFY,"AR",DA,ACHSDCR))
  1.  G S1:ACHSDCR<1,S11:'$D(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",ACHSDCR,0)) I ACHSEDT'>$P(^(0),U,2) S ACHSEDT=$P(^(0),U,2)
  1.  G S11
  1.  ;
  1. S2 ;EP - For export Re-Generation.
  1.  G ERR:ACHSEDT=0
  1.  ;
  1.  ;ACHS*3.1*15 IHS.OIT.FCJ ADDED ACHSFDTT TO NXT LINE
  1.  S ACHSFDT=ACHSBDT,ACHSLDAT=ACHSEDT,ACHSAFAC=$P(^AUTTLOC(DUZ(2),0),U,10),ACHSFDTT=""
  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.  I $$PARM^ACHS(2,9)="Y" F ACHS="252F","254V" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0))
  1.  I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" F ACHS="252G","252R","254D","254L","254M" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0))
  1. S3 ;
  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 ;
  1.  S ACHSTY=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY))
  1.  G S3:ACHSTY="",S4:ACHSTY="ZA"!(ACHSTY="IP")
  1.  S P=0
  1. S5 ;
  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 DA=0
  1. S6 ;
  1.  S DA=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY,P,DA))
  1.  ;
  1.  G S5:DA<1
  1.  ;ITSC/SET/JVK ACHS*3.1*7 11/26/03 CMT OUT NXT TWO
  1.  ;S ACHSESIG=$P($G(^ACHSF(DUZ(2),"D",P,0)),U,24)
  1.  ;S ACHSADT=$P($G(^ACHSESIG(DUZ(2),0)),U,3)
  1.  ;ITSC/SET/JVK END ACHS*3.1*7
  1.  S ACHSDEST=$P($G(^ACHSF(DUZ(2),"D",P,0)),U,17),ACHSCTY=ACHSTY
  1.  G S6:'$D(^ACHSF(DUZ(2),"D",P,"T",DA,0)) S X=$P(^(0),U,4),X=$P(X,".",1)_$E($P(X,".",2)_"00",1,2),ACHSIPA=$E(X+1000000000000,2,13) I ACHSCTY="C" S ACHSCTY=$P(^(0),U,5)
  1.  G S6:'$D(^ACHSF(DUZ(2),"D",P,0)) S ACHSDOCR=^(0),ACHSTOS=$P(ACHSDOCR,U,4)
  1.  S ACHSDR3=$G(^ACHSF(DUZ(2),"D",P,3),"")
  1.  S ACHSPROV=$P(^ACHSF(DUZ(2),"D",P,0),U,8)
  1.  I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S7
  1.  S:ACHSTY="P"&(ACHSDEST'="F") ^ACHSTXPD(P,DA)=""
  1.  S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST
  1. S7 ;
  1.  ;ITSC/SET/JVK NOTE THIS LINE TO SEND REGARDLESS OF PAYMENT DESTINATION
  1.  ;ONLY FI RECORDS IN RECORD TYPE 5
  1.  ;I ACHSTY'="P" G S8
  1.  ;ACHS*3.1*14 8.31.2007 IHS/OIT/FCJ changed nxt section for tribal stat data, commented out 6 lines added 1
  1.  ;I ACHSDEST="F"!(ACHSTY'="P") G S8
  1.  ;I $$PARM^ACHS(2,9)'="Y" G S7A 
  1.  ;S ^ACHSTXPG(ACHSTOS,P,DA)="" 
  1. S7A ;
  1.  ;I ACHSF638'="Y" G S8
  1.  ;S:'$P(ACHSDOCR,U,3) ^ACHSTXPG(ACHSTOS,P,DA)=""
  1.  ;G S6
  1.  ;ACHS*3.1*15 IHS.OIT.FCJ ADDED ACHSFDTT TO NXT LINE
  1.  I ACHSTY="P",$$PARM^ACHS(2,9)="Y",ACHSF638="Y",$P(ACHSDOCR,U,3)'=2 S ^ACHSTXPG(ACHSTOS,P,DA)="" S:ACHSFDTT="" ACHSFDTT=ACHSBDT
  1. S8 ;
  1.  G S6:ACHSTY="P"
  1.  ;ITSC/SET/JVK ACHS*3.1*7 11/26/03 CMT OUT NXT 1
  1.  ;G S6:(ACHSESIG="")&(ACHSBDT>ACHSADT)
  1.  ;ACHS*3.1*14 8.31.2007 IHS/OIT/FCJ CMT OUT 3 LINES ADDED 2
  1.  ;I ACHSF638="Y",$$PARM^ACHS(2,9)'="Y" G S6
  1.  ;S ^ACHSTXOB(P,DA)=""
  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
  1.  D AF
  1.  G:ACHSF638="Y" S6   ;ACHS*3.1*14T 9.31.2007 IHS/OIT/FCJ Tribal sites do not need to create DHR records
  1.  S (ACHSX,X1)=$P(ACHSDOCR,U,14)
  1.  D FYCVT^ACHSFU
  1.  S ACHSXLOC=ACHSFC
  1.  S:ACHSY<1987 ACHSXLOC="0"_$E(ACHSFC,2,3)
  1.  ;Y2000 The following line is OK ... YY is Y2K correct in CHS
  1.  ;ACHS*3.1*16 10/15/2009 IHS.OIT.FCJ SPLIT NEXT LINE AND ADDED CORRECT FY
  1.  ;S ACHSEFDT=$E(DT,4,5)_$E(DT,6,7)_$E(DT,2,3),ACHSCDE=$S(ACHSCTY="I":"05013",ACHSCTY="F":"05024",ACHSCTY="P":"05025",ACHSTY="S":"05015",1:""),ACHSDOCN=0_X1_ACHSXLOC_$P(ACHSDOCR,U)
  1.  S ACHSEFDT=$E(DT,4,5)_$E(DT,6,7)_$E(DT,2,3),ACHSCDE=$S(ACHSCTY="I":"05013",ACHSCTY="F":"05024",ACHSCTY="P":"05025",ACHSTY="S":"05015",1:"")
  1.  S ACHSDOCN=$E($P(ACHSDOCR,U,27),3,4)_ACHSXLOC_$P(ACHSDOCR,U)
  1.  S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST
  1.  G ERROR^ACHSTX:ACHSCDE=""
  1.  D CANOBJ^ACHSTX8
  1.  S ACHSFED=$S($P(^AUTTVNDR(ACHSPROV,11),U,10)=2:2,1:1)
  1.  S ACHSRCT=ACHSRCT+1         ;RECORD COUNT
  1.  S ACHSRTYP(2)=ACHSRTYP(2)+1
  1.  S ^ACHSDATA(ACHSRCT)="2"_ACHSEFDT_ACHSCDE_$S(ACHSTOS=1:323,ACHSTOS=2:324,ACHSTOS=3:325,1:"")_ACHSDOCN_$J("",13)_"1"_X1_ACHSCAN_ACHSOBJC_ACHSIPA_ACHSFED_$J("",16)
  1.  ;
  1.  I $L(^ACHSDATA(ACHSRCT))'=80 W !!,*7,*7,"A DHR RECORD WAS PRODUCED THAT WAS NOT 80 CHARACTERS IN LENGTH:",!!,^(ACHSRCT),!,*7,*7 G ERROR^ACHSTX
  1.  I ACHSRCT=1 S ACHSFDT=ACHSBDT W !!,"NUMBER OF RECORDS PROCESSED = ",!!
  1.  S ACHSERR=0 D S1^ACHSTXFT I ACHSERR G ERROR^ACHSTX  ;ACHS*3.1*13 6.13.2007 IHS/OIT/FCJ Used for testing UFMS data
  1.  I ACHSRCT#25=0 W $J(ACHSRCT,8)
  1.  D BC
  1.  G S6
  1.  ;
  1. ERR ;
  1.  W !!,*7,*7,"DCR REGISTER ERROR YOU MUST CLOSE YOUR REGISTERS FIRST"
  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.  S ACHSROUT=ACHSRCT
  1.  S:ACHSRCT>2 ACHSROUT=ACHSRCT
  1.  K ACHSDEST,ACHSDCR,ACHSF638,ACHSIPA,ACHSCAN,ACHSCDE,ACHSCTY,ACHSDOCN,ACHSDOCR,ACHSEFDT,ACHSPROV,ACHSFED,ACHSOBJC,ACHSTOS,DA,ACHSTY,X1,ACHSXLOC
  1.  G ^ACHSTX3
  1.  ;
  1. AF ;Area - FI records set globals   ;ACHS*3.1*14 8.31.2007 IHS/OIT/FCJ ADDED SECTION
  1.  S:ACHSTY="P"&(ACHSDEST'="F")&($$PARM^ACHS(2,12)="Y") ^ACHSTXPD(P,DA)=""
  1.  ;I $$PARM^ACHS(2,11)="Y" S ^ACHSTXOB(P,DA)=""
  1.  I $$PARM^ACHS(2,11)="Y",ACHSDEST="F" S ^ACHSTXOB(P,DA)=""  ;ACHS*3.1*22 IHS/OIT/FCJ "I" TYPE DOC WERE BEING SENT TO THE FI
  1.  I ($$PARM^ACHS(2,11)="Y")!($$PARM^ACHS(2,12)="Y") 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
  1.  .S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST
  1.  Q
  1. BC ;EP - Generate Export records 2B and 2C for CORE.
  1.  ;
  1.  ; 2B
  1.  S ACHSCAN="IHS/AP:"_$E(ACHSCAN,2,3)_"/SU:"_$E(ACHSCAN,4)_"/YR:"_$E(ACHSCAN,5)_"/CC:"_$E(ACHSCAN,6,7)
  1.  S ACHSCAN=ACHSCAN_$J("",30-$L(ACHSCAN))
  1.  ;
  1.  S ACHSOBJC=$E($P($G(^ACHSOCC($P(ACHSDOCR,U,10),0)),U,2),1,20)
  1.  S ACHSOBJC=ACHSOBJC_$J("",20-$L(ACHSOBJC))
  1.  ;
  1.  S ACHSX=$P(ACHSDOCR,U,14)
  1.  I '$D(ACHSDR3) S ACHSDR3=$S($D(ACHSDIEN):$G(^ACHSF(DUZ(2),"D",ACHSDIEN,3)),1:"")
  1.  S ACHSABD=$E($P(ACHSDR3,U,1),4,7)
  1.  S ACHSAED=$E($P(ACHSDR3,U,2),4,7)
  1.  K ACHSDR3
  1.  D FYCVT^ACHSFU
  1.  S %="2B"_ACHSFC_"."_ACHSCAN_ACHSOBJC_ACHSY_ACHSABD_ACHSAED
  1.  D SET(%)
  1.  ;
  1.  ; 2C
  1.  ; Vendor EIN
  1.  S %=$E($P(^AUTTVNDR(ACHSPROV,11),U)_$J("",10),1,10)_$E($P(^AUTTVNDR(ACHSPROV,11),U,2)_"  ",1,2)
  1.  ;
  1.  ; Vendor Name
  1.  S %=%_$E($P(^AUTTVNDR(ACHSPROV,0),U),1,30)
  1.  S %=%_$J("",42-$L(%))
  1.  ;
  1.  ; 1/8/01  pmf  the way this was written, it would crash without
  1.  ; a vendor address in the database.  I'm changing it so that if
  1.  ; no address is on file, it works.  This may backfire - we may
  1.  ;find out that somebody NEEDS the address and are screwed without
  1.  ;it.  But for now, it's gonna go.
  1.  ;
  1.  ; Vendor CityStZip
  1.  ;S %=%_$P(^AUTTVNDR(ACHSPROV,13),U,2)_","_$P(^DIC(5,$P(^AUTTVNDR(ACHSPROV,13),U,3),0),U,2)_","_$P(^AUTTVNDR(ACHSPROV,13),U,4)
  1.  S ACHSVADR=$G(^AUTTVNDR(ACHSPROV,13))
  1.  S %=%_$P(ACHSVADR,U,2)_","
  1.  S ACHSVAD2=$P(ACHSVADR,U,3) I ACHSVAD2'="" S ACHSVAD2=$P(^DIC(5,ACHSVAD2,0),U,2)
  1.  S %=%_ACHSVAD2_","_$P(ACHSVADR,U,4) K ACHSVADR,ACHSVAD2
  1.  ;
  1.  ;end of chaNge to allow no address
  1.  ;
  1.  ;adjust to 72 characters long
  1.  S %=$E(%,1,72),%=%_$J("",72-$L(%))
  1.  ;
  1.  S %="2C"_%
  1.  D SET(%)
  1.  ;
  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.  ;