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

ACHSTXA1.m

Go to the documentation of this file. 
  1. ACHSTXA1 ; IHS/ITSC/PMF - EXPORT DATA - RECORD 2(DHR), SPECIFIC RE-EXPORTS ;  [ 11/26/2003  8:04 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,14,16**;JUNE 11,2001
  1.  ;ITSC/SET/JVK ACHS*3.1*7 - TEST FOR NO E-SIG
  1.  ; This routine was created from ACHSTX2, for use with exporting 
  1.  ; specifically selected document transactions.  If any change in logic
  1.  ; is made to ACHSTX2, the change should also be made to this routine.
  1.  ;ACHS*3.1*16 10/15/2009 IHS.OIT.FCJ FX FY 2 DIG YEAR PROBLEM
  1.  ;
  1.  D LINES^ACHSFU
  1.  W @IOF,!,$$REPEAT^XLFSTR("*",80),!,$$C^XBFUNC("RE-EXPORT SELECTED CHS DATA"),!,$$REPEAT^XLFSTR("*"),!
  1.  S ACHSCHSS=""
  1.  D ^ACHSUF
  1.  K ACHSCHSS
  1.  D KILLGLBS^ACHSTX
  1.  S (J,ACHSDCR,ACHSEDT,ACHSBDT)=0,ACHSRR="",ACHSF638=$$PARM^ACHS(0,8)
  1.  F ACHS=2:1:7 S ACHSRTYP(ACHS)=0
  1.  W !?10,"FACILITY NAME: ",$$LOC^ACHS
  1.  S ACHSBDT=0,ACHSEDT=3990000
  1. S2 ;
  1.  G ERR:ACHSEDT=0
  1.  S ACHSFDT=ACHSBDT
  1.  S ACHSAFAC=$P(^AUTTLOC(DUZ(2),0),U,10)
  1.  I $$PARM^ACHS(2,25)="Y" S X=$$PARM^ACHS(0,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(^TMP("ACHSTXAR",$J,ACHSBDT))
  1.  G CVTEND1:ACHSBDT<1!(ACHSBDT>ACHSEDT)
  1.  S ACHSLDAT=ACHSBDT
  1.  S ACHSDIEN=""
  1. S4 ;
  1.  S ACHSDIEN=$O(^TMP("ACHSTXAR",$J,ACHSBDT,ACHSDIEN))
  1.  G S3:ACHSDIEN=""
  1.  G S4:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,0)) S ACHSDOCR=^(0)
  1.  G S4:$P(ACHSDOCR,U,3)=2
  1.  S ACHSTOS=$P(ACHSDOCR,U,4)
  1.  S ACHSTIEN=0
  1. S5 ;
  1.  S ACHSTIEN=$O(^TMP("ACHSTXAR",$J,ACHSBDT,ACHSDIEN,ACHSTIEN))
  1.  G S4:ACHSTIEN<1
  1.  G S5:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)) S ACHSTRNR=^(0)
  1.  S ACHSTY=$P(ACHSTRNR,U,2)
  1.  G S5:ACHSTY="ZA"!(ACHSTY="IP")
  1.  ;ITSC/SET/JVK ACHS*3.1*7 10/30/2003
  1.  ;ITSC/SET/JVK ACHS*3.1*7 11/26/2003 CMT OUT NXT 2
  1.  ;S ACHSESIG=$P(ACHSDOCR,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(ACHSDOCR,U,17),ACHSCTY=ACHSTY
  1.  ;
  1.  S X=$P(ACHSTRNR,U,4),X=$P(X,".",1)_$E($P(X,".",2)_"00",1,2),ACHSIPA=$E(X+1000000000000,2,13)
  1.  I ACHSCTY="C" S ACHSCTY=$P(ACHSTRNR,U,5)
  1.  I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S7
  1.  S:ACHSTY="P"&(ACHSDEST'="F") ^ACHSTXPD(ACHSDIEN,ACHSTIEN)=""
  1.  S ACHSPROV=$P(ACHSDOCR,U,8)
  1.  S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST
  1. S7 ;
  1.  ;ITSC/SET/JVK ACHS*3.1*7 CMT OUT NXT 1
  1.  ;I ACHSDEST="F"!(ACHSTY'="P") G S8
  1.  I $$PARM^ACHS(2,9)'="Y" G S7A
  1.  S ^ACHSTXPG(ACHSTOS,ACHSDIEN,ACHSTIEN)=""
  1. S7A ;
  1.  I ACHSF638'="Y" G S8
  1.  S:'$P(ACHSDOCR,U,3) ^ACHSTXPG(ACHSTOS,ACHSDIEN,ACHSTIEN)=""
  1.  ;ACHS*3.1*14 IHS/OIT/FCJ Commented out next line because some 638 sites send FI data
  1.  ;G S5
  1. S8 ;
  1.  G S5:ACHSTY="P"
  1.  ;ITSC/SET/JVK ACHS*3.1*7 11/26/2003 CMT NXT 1
  1.  ;G S5:(ACHSESIG="")&(ACHSBDT>ACHSADT)
  1.  I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S5
  1.  S ^ACHSTXOB(ACHSDIEN,ACHSTIEN)=""
  1.  ;
  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.  ;
  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:"")
  1.  ;ACHS*3.1*16 10/15/2009 IHS.OIT.FCJ ADDED CORRECT FY
  1.  ;S ACHSDOCN=0_X1_ACHSXLOC_$P(ACHSDOCR,U)
  1.  S ACHSDOCN=$E($P(ACHSDOCR,U,27),3,4)_ACHSXLOC_$P(ACHSDOCR,U)
  1.  S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST
  1.  ;
  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,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.  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.  W $J(ACHSRCT,8)
  1.  D BC^ACHSTX2
  1.  G S5
  1.  ;
  1. ERR ;
  1.  W !!,*7,*7,"DCR REGISTER ERROR YOU MUST CLOSE YOUR REGISTERS FIRST"
  1.  D ^%ZISC,KILL^ACHSTX8
  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,ACHSSCC,ACHSTRNR,ACHSTY,X1,ACHSXLOC
  1.  G ^ACHSTX3
  1.  ;