ACHSTXF1 ; IHS/OIT/FCJ - RE-EXPORT DATA - RECORD 2U(UFMS), SPECIFIC RECORDS AND BATCHES ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,15**;JUN 11,2001
;ACHS*3.1*14 IHS/OIT/FCJ New routine
; This routine is called from ACHSTXAR, for use with re-exporting
; specifically selected document transactions.
;
D LINES^ACHSFU
W @IOF,!,$$REPEAT^XLFSTR("*",80),!,$$C^XBFUNC("RE-EXPORT SELECTED CHS DATA"),!,$$REPEAT^XLFSTR("*"),!
S ACHSCHSS=""
D ^ACHSUF
K ACHSCHSS
I '$D(ACHS("REXNUM")) D KILLGLBS^ACHSTX S ACHSBDT=0,ACHSEDT=3990000
S (J,ACHSDCR)=0,ACHSRR="",ACHSF638=$$PARM^ACHS(0,8)
F ACHS=2:1:7 S ACHSRTYP(ACHS)=0
W !?10,"FACILITY NAME: ",$$LOC^ACHS
S2 ;
S ACHSFDT=ACHSBDT
S ACHSAFAC=$P(^AUTTLOC(DUZ(2),0),U,10)
I $$PARM^ACHS(2,25)="Y" S X=$$PARM^ACHS(0,12) G AFACERR:+X<1 S ACHSAFAC=$P(^AUTTLOC(X,0),U,10)
I +ACHSAFAC<1 G AFACERR
I $$PARM^ACHS(2,9)="Y" F ACHS="252F","254V" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0))
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))
I $D(ACHS("REXNUM")) G RXB
S3 ;
S ACHSBDT=$O(^TMP("ACHSTXAR",$J,ACHSBDT))
G CVTEND1:ACHSBDT<1!(ACHSBDT>ACHSEDT)
S ACHSLDAT=ACHSBDT
S P=""
S4 ;
S P=$O(^TMP("ACHSTXAR",$J,ACHSBDT,P))
G S3:P=""
S (ACHSDOCR,ACHSDOCN,ACHSDOCT,ACHSIPA,ACHSDEST,ACHSCTY,ACHSDR3,ACHSTOS,ACHSDFY,X1)=""
S (ACHSXLOC,ACHSCDE,ACHSARCO,ACHSPROV,ACHSFED,ACHSEIN,ACHSDUNS,ACHSCTYP)=""
G S4:'$D(^ACHSF(DUZ(2),"D",P,0)) S ACHSDOCR=^(0)
G S4:$P(ACHSDOCR,U,3)=2 ;skip special transactions
S DA=0
S5 ;
S DA=$O(^TMP("ACHSTXAR",$J,ACHSBDT,P,DA))
G S4:DA<1
G S5:'$D(^ACHSF(DUZ(2),"D",P,"T",DA,0)) S ACHSDOCT=^(0)
S ACHSTY=$P(ACHSDOCT,U,2)
;ACHS*3.1*15 3.9.2009 IHS.OIT.FCJ ADDED "P" TO NXT LINE
G S5:ACHSTY="ZA"!(ACHSTY="IP")!(ACHSTY="P") ;skip paid documents
D S7^ACHSTXF
G S5
;
RXB ;RE-EXPORT A BATCH
;
S DA=0,P=0,ACHSTXDA=0,ACHSRCT=0
F S ACHSTXDA=$O(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),2,ACHSTXDA)) Q:ACHSTXDA'?1N.N D
.S P=$P(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),2,ACHSTXDA,0),U),DA=$P(^(0),U,2)
.S (ACHSDOCR,ACHSDOCN,ACHSDOCT,ACHSIPA,ACHSDEST,ACHSCTY,ACHSDR3,ACHSTOS,ACHSDFY,X1)=""
.S (ACHSXLOC,ACHSCDE,ACHSARCO,ACHSPROV,ACHSFED,ACHSEIN,ACHSDUNS,ACHSCTYP,ACHS2FY)=""
.Q:'$D(^ACHSF(DUZ(2),"D",P,0)) S ACHSDOCR=^(0)
.Q:$P(ACHSDOCR,U,3)=2 ;skip special transactions
.Q:'$D(^ACHSF(DUZ(2),"D",P,"T",DA,0)) S ACHSDOCT=^(0)
.S ACHSTY=$P(ACHSDOCT,U,2)
.Q:ACHSTY="ZA"!(ACHSTY="IP") ;skip paid documents
.D S7^ACHSTXF
S ACHSFDT=$P(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),0),U,2),ACHSLDAT=$P(^(0),U,3)
G CVTEND1
;
AFACERR ;
W !!,*7,*7,"AUTHORIZING FACILITY CODE ERROR - JOB CANCELLED"
D ^%ZISC,KILL^ACHSTX8
Q
;
CVTEND1 ;
S ACHSROUT=ACHSRCT
S:ACHSRCT>2 ACHSROUT=ACHSRCT
K ACHS2FY,ACHSDEST,ACHSDCR,ACHSF638,ACHSIPA,ACHSCAN,ACHSCDE,ACHSCTY,ACHSDOCN,ACHSDOCR,ACHSEFDT,ACHSPROV,ACHSFED,ACHSSCC,ACHSDOCT,ACHSTY,X1,ACHSXLOC
G ^ACHSTX3
;
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
+2 ;ACHS*3.1*14 IHS/OIT/FCJ New routine
+3 ; This routine is called from ACHSTXAR, for use with re-exporting
+4 ; specifically selected document transactions.
+5 ;
+6 DO LINES^ACHSFU
+7 WRITE @IOF,!,$$REPEAT^XLFSTR("*",80),!,$$C^XBFUNC("RE-EXPORT SELECTED CHS DATA"),!,$$REPEAT^XLFSTR("*"),!
+8 SET ACHSCHSS=""
+9 DO ^ACHSUF
+10 KILL ACHSCHSS
+11 IF '$DATA(ACHS("REXNUM"))
DO KILLGLBS^ACHSTX
SET ACHSBDT=0
SET ACHSEDT=3990000
+12 SET (J,ACHSDCR)=0
SET ACHSRR=""
SET ACHSF638=$$PARM^ACHS(0,8)
+13 FOR ACHS=2:1:7
SET ACHSRTYP(ACHS)=0
+14 WRITE !?10,"FACILITY NAME: ",$$LOC^ACHS
S2 ;
+1 SET ACHSFDT=ACHSBDT
+2 SET ACHSAFAC=$PIECE(^AUTTLOC(DUZ(2),0),U,10)
+3 IF $$PARM^ACHS(2,25)="Y"
SET X=$$PARM^ACHS(0,12)
IF +X<1
GOTO AFACERR
SET ACHSAFAC=$PIECE(^AUTTLOC(X,0),U,10)
+4 IF +ACHSAFAC<1
GOTO AFACERR
+5 IF $$PARM^ACHS(2,9)="Y"
FOR ACHS="252F","254V"
SET ACHS(ACHS)=$ORDER(^ACHS(3,DUZ(2),1,"B",ACHS,0))
+6 IF ACHSF638="Y"
IF $$PARM^ACHS(2,9)="Y"
FOR ACHS="252G","252R","254D","254L","254M"
SET ACHS(ACHS)=$ORDER(^ACHS(3,DUZ(2),1,"B",ACHS,0))
+7 IF $DATA(ACHS("REXNUM"))
GOTO RXB
S3 ;
+1 SET ACHSBDT=$ORDER(^TMP("ACHSTXAR",$JOB,ACHSBDT))
+2 IF ACHSBDT<1!(ACHSBDT>ACHSEDT)
GOTO CVTEND1
+3 SET ACHSLDAT=ACHSBDT
+4 SET P=""
S4 ;
+1 SET P=$ORDER(^TMP("ACHSTXAR",$JOB,ACHSBDT,P))
+2 IF P=""
GOTO S3
+3 SET (ACHSDOCR,ACHSDOCN,ACHSDOCT,ACHSIPA,ACHSDEST,ACHSCTY,ACHSDR3,ACHSTOS,ACHSDFY,X1)=""
+4 SET (ACHSXLOC,ACHSCDE,ACHSARCO,ACHSPROV,ACHSFED,ACHSEIN,ACHSDUNS,ACHSCTYP)=""
+5 IF '$DATA(^ACHSF(DUZ(2),"D",P,0))
GOTO S4
SET ACHSDOCR=^(0)
+6 ;skip special transactions
IF $PIECE(ACHSDOCR,U,3)=2
GOTO S4
+7 SET DA=0
S5 ;
+1 SET DA=$ORDER(^TMP("ACHSTXAR",$JOB,ACHSBDT,P,DA))
+2 IF DA<1
GOTO S4
+3 IF '$DATA(^ACHSF(DUZ(2),"D",P,"T",DA,0))
GOTO S5
SET ACHSDOCT=^(0)
+4 SET ACHSTY=$PIECE(ACHSDOCT,U,2)
+5 ;ACHS*3.1*15 3.9.2009 IHS.OIT.FCJ ADDED "P" TO NXT LINE
+6 ;skip paid documents
IF ACHSTY="ZA"!(ACHSTY="IP")!(ACHSTY="P")
GOTO S5
+7 DO S7^ACHSTXF
+8 GOTO S5
+9 ;
RXB ;RE-EXPORT A BATCH
+1 ;
+2 SET DA=0
SET P=0
SET ACHSTXDA=0
SET ACHSRCT=0
+3 FOR
SET ACHSTXDA=$ORDER(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),2,ACHSTXDA))
IF ACHSTXDA'?1N.N
QUIT
Begin DoDot:1
+4 SET P=$PIECE(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),2,ACHSTXDA,0),U)
SET DA=$PIECE(^(0),U,2)
+5 SET (ACHSDOCR,ACHSDOCN,ACHSDOCT,ACHSIPA,ACHSDEST,ACHSCTY,ACHSDR3,ACHSTOS,ACHSDFY,X1)=""
+6 SET (ACHSXLOC,ACHSCDE,ACHSARCO,ACHSPROV,ACHSFED,ACHSEIN,ACHSDUNS,ACHSCTYP,ACHS2FY)=""
+7 IF '$DATA(^ACHSF(DUZ(2),"D",P,0))
QUIT
SET ACHSDOCR=^(0)
+8 ;skip special transactions
IF $PIECE(ACHSDOCR,U,3)=2
QUIT
+9 IF '$DATA(^ACHSF(DUZ(2),"D",P,"T",DA,0))
QUIT
SET ACHSDOCT=^(0)
+10 SET ACHSTY=$PIECE(ACHSDOCT,U,2)
+11 ;skip paid documents
IF ACHSTY="ZA"!(ACHSTY="IP")
QUIT
+12 DO S7^ACHSTXF
End DoDot:1
+13 SET ACHSFDT=$PIECE(^ACHSTXST(DUZ(2),1,ACHS("REXNUM"),0),U,2)
SET ACHSLDAT=$PIECE(^(0),U,3)
+14 GOTO CVTEND1
+15 ;
AFACERR ;
+1 WRITE !!,*7,*7,"AUTHORIZING FACILITY CODE ERROR - JOB CANCELLED"
+2 DO ^%ZISC
DO KILL^ACHSTX8
+3 QUIT
+4 ;
CVTEND1 ;
+1 SET ACHSROUT=ACHSRCT
+2 IF ACHSRCT>2
SET ACHSROUT=ACHSRCT
+3 KILL ACHS2FY,ACHSDEST,ACHSDCR,ACHSF638,ACHSIPA,ACHSCAN,ACHSCDE,ACHSCTY,ACHSDOCN,ACHSDOCR,ACHSEFDT,ACHSPROV,ACHSFED,ACHSSCC,ACHSDOCT,ACHSTY,X1,ACHSXLOC
+4 GOTO ^ACHSTX3
+5 ;
