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

ACHSTXF1.m

Go to the documentation of this file.
  1. ACHSTXF1 ; IHS/OIT/FCJ - RE-EXPORT DATA - RECORD 2U(UFMS), SPECIFIC RECORDS AND BATCHES ;
  1. ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,15**;JUN 11,2001
  1. ;ACHS*3.1*14 IHS/OIT/FCJ New routine
  1. ; This routine is called from ACHSTXAR, for use with re-exporting
  1. ; specifically selected document transactions.
  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. I '$D(ACHS("REXNUM")) D KILLGLBS^ACHSTX S ACHSBDT=0,ACHSEDT=3990000
  1. S (J,ACHSDCR)=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. S2 ;
  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. I $D(ACHS("REXNUM")) G RXB
  1. S3 ;
  1. S ACHSBDT=$O(^TMP("ACHSTXAR",$J,ACHSBDT))
  1. G CVTEND1:ACHSBDT<1!(ACHSBDT>ACHSEDT)
  1. S ACHSLDAT=ACHSBDT
  1. S P=""
  1. S4 ;
  1. S P=$O(^TMP("ACHSTXAR",$J,ACHSBDT,P))
  1. G S3:P=""
  1. S (ACHSDOCR,ACHSDOCN,ACHSDOCT,ACHSIPA,ACHSDEST,ACHSCTY,ACHSDR3,ACHSTOS,ACHSDFY,X1)=""
  1. S (ACHSXLOC,ACHSCDE,ACHSARCO,ACHSPROV,ACHSFED,ACHSEIN,ACHSDUNS,ACHSCTYP)=""
  1. G S4:'$D(^ACHSF(DUZ(2),"D",P,0)) S ACHSDOCR=^(0)
  1. G S4:$P(ACHSDOCR,U,3)=2 ;skip special transactions
  1. S DA=0
  1. S5 ;
  1. S DA=$O(^TMP("ACHSTXAR",$J,ACHSBDT,P,DA))
  1. G S4:DA<1
  1. G S5:'$D(^ACHSF(DUZ(2),"D",P,"T",DA,0)) S ACHSDOCT=^(0)
  1. S ACHSTY=$P(ACHSDOCT,U,2)
  1. ;ACHS*3.1*15 3.9.2009 IHS.OIT.FCJ ADDED "P" TO NXT LINE
  1. G S5:ACHSTY="ZA"!(ACHSTY="IP")!(ACHSTY="P") ;skip paid documents
  1. D S7^ACHSTXF
  1. G S5
  1. ;
  1. RXB ;RE-EXPORT A BATCH
  1. ;
  1. S DA=0,P=0,ACHSTXDA=0,ACHSRCT=0
  1. F S ACHSTXDA=$O(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),2,ACHSTXDA)) Q:ACHSTXDA'?1N.N D
  1. .S P=$P(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),2,ACHSTXDA,0),U),DA=$P(^(0),U,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. .Q:'$D(^ACHSF(DUZ(2),"D",P,0)) S ACHSDOCR=^(0)
  1. .Q:$P(ACHSDOCR,U,3)=2 ;skip special transactions
  1. .Q:'$D(^ACHSF(DUZ(2),"D",P,"T",DA,0)) S ACHSDOCT=^(0)
  1. .S ACHSTY=$P(ACHSDOCT,U,2)
  1. .Q:ACHSTY="ZA"!(ACHSTY="IP") ;skip paid documents
  1. .D S7^ACHSTXF
  1. S ACHSFDT=$P(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),0),U,2),ACHSLDAT=$P(^(0),U,3)
  1. G CVTEND1
  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 ACHS2FY,ACHSDEST,ACHSDCR,ACHSF638,ACHSIPA,ACHSCAN,ACHSCDE,ACHSCTY,ACHSDOCN,ACHSDOCR,ACHSEFDT,ACHSPROV,ACHSFED,ACHSSCC,ACHSDOCT,ACHSTY,X1,ACHSXLOC
  1. G ^ACHSTX3
  1. ;