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

ACHSTXP2.m

Go to the documentation of this file. 
  1. ACHSTXP2 ; IHS/ITSC/FCJ - EXPORT PREV DATA (2/2) - RECORD 2(DHR), SET GLOBALS FOR OTHER RECORD TYPES ;     [ 10/14/2004  12:53 PM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**11**;JUNE 11, 2001
  1.  ;3.1*11 IHS/ITSC/FCJ 8.18.04 NEW ROUTINE-ORIGINAL RTN ACHSTX2
  1.  ;  SETS DATE FOR EXPORT: 10.01.01 THRU 09.30.04
  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.  ;ITSC/SET/JVK ACHS*3.1*11 FOR OUR PURPOSE ALL SITES WILL BE 638
  1.  ;SO THAT NO DHR RECORDS ARE CREATED
  1.  ;S (J,ACHSDCR)=0,ACHSRR="",ACHSF638=$P(^ACHSF(DUZ(2),0),U,8)
  1.  S (J,ACHSDCR)=0,ACHSRR="",ACHSF638="Y"
  1.  S ACHSEXP="Y"
  1.  S ACHSEDT=3040930,ACHSBDT=3001001
  1.  F ACHS=2:1:7 S ACHSRTYP(ACHS)=0
  1. S2 ;export Re-Generation.
  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.  ;I $$PARM^ACHS(2,9)="Y" F ACHS="252F","254V" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0))
  1.  I ACHSEXP="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.  I ACHSF638="Y",ACHSEXP="Y" F ACHS="252G","252R","254D","254L","254M" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0))
  1.  ;
  1.  S ACHSBDT=ACHSBDT-1
  1. S3 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.  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.  ;I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S7
  1.  I ACHSF638="Y",ACHSEXP="Y" G S7
  1.  S:ACHSTY="P"&(ACHSDEST'="F") ^ACHSTXPD(P,DA)=""
  1.  S ACHSPROV=$P(^ACHSF(DUZ(2),"D",P,0),U,8)
  1.  S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST
  1. S7 ;
  1.  I ACHSDEST="F"!(ACHSTY'="P") G S8
  1.  ;I $$PARM^ACHS(2,9)'="Y" G S7A
  1.  I ACHSEXP'="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. S8 ;
  1.  G S6:ACHSTY="P"
  1.  ;I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S6
  1.  I ACHSF638="Y",ACHSEXP="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.  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.  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),ACHSPROV=$P(ACHSDOCR,U,8)
  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.  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. 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.  ;