IBCEFG7 ;ALB/TMP - OUTPUT FORMATTER GENERIC FORM PROCESSING ;06-MAR-96
;;2.0;INTEGRATED BILLING;**52,84,96,51,137,191,320,608,641**;21-MAR-94;Build 61
;;Per VA Directive 6402, this routine should not be modified
Q
;
;/IB*2*608 (vd) - US2486 added the parameter IBRSBTST to indicate a claim is a "TEST"
; that is being RESUBMITTED and assists with the COB Output Formatter data.
FORM(IBFORM,IBQUE,IBNOASK,IBQDT,ZTSK,IBABORT,IBRSBTST) ;For ien IBFORM, extract data using
; output generater
; IBQUE = the output queue for transmitted forms or the printer queue
; for printed output
; IBNOASK = flag that says user interaction for queuing is not needed
; 0 or null = ask, 1 = don't ask
; IBQDT = the date/time to queue the job (optional)
;
; Sets ZTSK only if job is queued
;
; IBABORT = output parameter which says user aborted forms output.
; Pass by reference. The $$QUEUE function returned false.
;
; IBRSBTST = 1, this indicates the claim is being resubmitted as a "TEST" claim and should be
; used by the OUTPUT FORMATTER entries to determine what COB information is
; going out. - IB*2.0*608 (vd) US2486
;
N IBF2,IBTYP,POP,ZTIO,ZTRTN,ZTDESC,ZTSAVE,ZTREQ,ZTDTH,ZTREQ
S IBTYP=$P($G(^IBE(353,IBFORM,2)),U,2),IBQUE=$G(IBQUE),IBABORT=0
G:$S(IBTYP'="S":$G(^IBE(353,IBFORM,"EXT"))=""&($G(^IBE(353,+$P($G(^IBE(353,IBFORM,2)),U,5),"EXT"))=""),1:'$G(IBIFN)) FORMQ
;I IBTYP="P",IBQUE="" D DEV(IBFORM) G:$G(POP) FORMQ ;WCJ;US3380
I IBTYP="P",IBQUE="" D DEV(IBFORM,,.IBABORT) G:$G(POP) FORMQ ;WCJ;US3380
I IBTYP="T" D:$G(IBNOASK) Q:$G(IBNOASK) I '$$QUEUE(IBFORM) S:$O(^TMP("IBRESUBMIT",$J,0)) ^TMP("IBRESUBMIT",$J)="ABORT" S IBABORT=1 Q
. S ZTRTN="FORMOUT^IBCEFG7",ZTIO="",ZTDESC="OUTPUT FORMATTER - FORM: "_$P($G(^IBE(353,IBFORM,0)),U),ZTSAVE("IB*")="",ZTDTH=$S($G(IBQDT):IBQDT,1:$$NOW^XLFDT())
. S:$D(^TMP("IBRESUBMIT",$J)) ZTSAVE("^TMP(""IBRESUBMIT"",$J)")="",ZTSAVE("^TMP(""IBNOT"",$J)")="",ZTSAVE("^TMP(""IBRESUBMIT"",$J,")="",ZTSAVE("^TMP(""IBNOT"",$J,")=""
. I $D(^TMP("IBSELX",$J)) S ZTSAVE("^TMP(""IBSELX"",$J,")="",ZTSAVE("^TMP(""IBSELX"",$J)")=""
. S:'$G(DUZ) DUZ=.5
. D ^%ZTLOAD
I '$G(ZTSK) D FORMOUT
FORMQ Q
;
FORMOUT ; Queued job entrypoint - IBFORM needs to be defined
; IBQUE needs to be defined if using default transmission output
N IB2,IBTYP,IBPAR
K ^TMP("IBXDATA",$J)
S ZTREQ="@"
S IB2=$G(^IBE(353,IBFORM,2)),IBPAR=+$P(IB2,U,5),IBTYP=$P(IB2,U,2)
;
; Execute PRE-PROCESSOR
I IBTYP'="S" D FPRE(IBFORM,IBPAR,.IBXERR)
G:$G(IBXERR)'="" FOUTQ
;
; Extract records - this should include call(s) to $$EXTRACT^IBCEFG()
I IBTYP'="S" D
.I $G(^IBE(353,IBFORM,"EXT"))'="" X ^("EXT") ;Form extract
.I $G(^IBE(353,IBFORM,"EXT"))="",$G(^IBE(353,IBPAR,"EXT"))'="" X ^("EXT") ;Parent form extract
I IBTYP="S" D G Q1
.N PARAM,Z,Z0
.S PARAM(1)="BILL-SEARCH",Z0=$G(^DGCR(399,IBIFN,0))
.S Z=$P(Z0,U,21) S:Z="" Z="P" S PARAM(2)=$P($G(^DGCR(399,IBIFN,"I"_($F("PST",Z)-1))),U),PARAM(3)=$S($P(Z0,U,5)<3:"I",1:"O")
.S Z=$$EXTRACT^IBCEFG(IBFORM,IBIFN,1,.PARAM)
;
G:'$D(^TMP("IBXDATA",$J)) FOUTQ
;
; If an output routine exists, use it, otherwise use the generic ones
I $G(^IBE(353,IBFORM,"OUT"))'="" X ^("OUT") G FOUTQ
I $G(^IBE(353,IBFORM,"OUT"))="",$G(^IBE(353,IBPAR,"OUT"))'="" X ^("OUT") G FOUTQ
;
I IBTYP="P" D PRINT(IBFORM) D:'$D(ZTQUEUED) ^%ZISC G FOUTQ
I IBTYP="T" D:$G(IBQUE)'="" TRANSMIT(IBFORM,IBQUE) G FOUTQ
;
FOUTQ D FPOST(IBFORM,IBPAR,.IBXERR) ; Execute POST-PROCESSOR, if any
K ^TMP("IBXDATA",$J),^TMP("IBXEDIT",$J)
Q1 Q
;
PRINT(IBFORM) ; Print data from extract global for form IBFORM
; Extract records - this should include call(s) to $$EXTRACT^IBCEFG()
N IB1,IB2,IB3,IBREC
;LOOP THROUGH RECORD/PAGE/LINE/COL
S IBREC="" F S IBREC=$O(^TMP("IBXDATA",$J,IBREC)) Q:IBREC="" D ;Rec
. ;Page/line
. F IB1=1:1:+$O(^TMP("IBXDATA",$J,IBREC,""),-1) W:IB1>1 @IOF W ?0 F IB2=1:1:+$O(^TMP("IBXDATA",$J,IBREC,IB1,""),-1) W:IB2>1 ! S IB3="" D
.. ; Column
.. F S IB3=$O(^TMP("IBXDATA",$J,IBREC,IB1,IB2,IB3)) Q:IB3="" W ?(IB3-1),^(IB3)
. ;Only print form feed if more records to print - not on last record
. I $O(^TMP("IBXDATA",$J,IBREC))'="" W @IOF
Q
;
TRANSMIT(IBFORM,IBQUE) ; Send data from extract global to queue IBQUE
;IBFORM = ien of the form to be transmitted (required)
N IB1,IB2,IB3,IBREC,IBOUT,IBCT,IBSUB,Z,XMDUZ,XMSUBJ,XMBODY,XMTO
K ^TMP("IBXTXMT",$J),^TMP("IBX",$J)
Q:$G(IBQUE)=""
;
S IBDELIM=$P($G(^IBE(353,+$S($P($G(^IBE(353,IBFORM,2)),U,5):$P(^(2),U,5),1:IBFORM),2)),U,7)
S:IBDELIM="" IBDELIM="^"
;Loop through record/page/line/column
S IBREC="",(IBSIZE,IBCT)=0,IBMSG=1
F S IBREC=$O(^TMP("IBXDATA",$J,IBREC)) Q:IBREC="" D
.S ^TMP("IBX",$J,IBREC)=IBCT
.S IB1="" F S IB1=$O(^TMP("IBXDATA",$J,IBREC,IB1)) Q:IB1="" D
..S (IB2,IBOUT)=""
..F S IB2=$O(^TMP("IBXDATA",$J,IBREC,IB1,IB2)) D:IB2=""&$L(IBOUT) MSG(IBREC,IBOUT,.IBMSG,.IBSIZE,.IBCT) Q:IB2="" D
...S IB3="" F S IB3=$O(^TMP("IBXDATA",$J,IBREC,IB1,IB2,IB3)) Q:IB3="" S IBP=^(IB3) S:IBP?.E1L.E IBP=$$UP^XLFSTR(IBP) S $P(IBOUT,IBDELIM,IB3)=IBP
;
;Send mail message(s) for extract
S XMDUZ=DUZ,XMTO(IBQUE)="",IBSUB="OUTPUT FORMATTER: "_$P($G(^IBE(353,IBFORM,0)),U)
S Z="" F S Z=$O(^TMP("IBXTXMT",$J,Z)) Q:'Z S XMBODY="^TMP(""IBXTXMT"","_$J_","_Z_")",XMSUBJ=IBSUB_" ("_Z_")" D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
;
K ^TMP("IBXTXMT",$J),^TMP("IBX",$J)
Q
;
MSG(IBREC,LINE,MSG,SIZE,CT) ; Set up global for transmission line
; IBREC = record number being processed
; LINE = actual text to be output in mail message line
; MSG = the message seq # to output this record in (pass by reference)
; SIZE = current size of the message (pass by reference)
; CT = the last line # in message for the text (pass by reference)
N Z,Z0,LLEN
S LLEN=$L(LINE)
I (LLEN+SIZE)>30000 D
.Q:'$G(^TMP("IBX",$J,IBREC)) ;Record itself is > 30000 - let it go
.S (SIZE,CT)=0,Z=$G(^TMP("IBX",$J,IBREC)),^(IBREC)=0
.F S Z=$O(^TMP("IBXTXMT",$J,MSG,Z)) Q:'Z S CT=CT+1,Z0=^(Z),^TMP("IBXTXMT",$J,MSG+1,CT)=Z0,SIZE=SIZE+$L(Z0) K ^TMP("IBXTXMT",$J,MSG,Z)
.S MSG=MSG+1
S CT=CT+1,^TMP("IBXTXMT",$J,MSG,CT)=LINE,SIZE=SIZE+LLEN
Q
;
DEV(IBFORM,NOQ,IBABORT) ;WCJ;US3380 added IBABORT
N IBFTYPE
S:'$G(NOQ) %ZIS="Q" S %ZIS("A")="Output Device: "
S %ZIS("B")=$P($G(^IBE(353,IBFORM,0)),"^",2)
D ^%ZIS
;G:POP DEVQ;WCJ;US3880
I POP S IBABORT=1 G DEVQ ;WCJ;US3880
I $D(IO("Q")) D G DEVQ
.S ZTRTN="FORMOUT^IBCEFG7",ZTDESC="PRINT FORM: "_$P($G(^IBE(353,IBFORM,0)),U),ZTSAVE("IB*")="" K ZTIO
.I $D(^TMP("IBQONE",$J)) D
..S IBJ="",IBFTYPE="IBCFP"_$S($P($G(^IBE(353,IBFORM,2)),U,5):$P(^(2),U,5),1:IBFORM)
..S ZTSAVE("^XTMP(IBFTYPE,$J,")=""
.D ^%ZTLOAD K IO("Q") D HOME^%ZIS
.I $G(IBFTYPE)'="" K ^XTMP(IBFTYPE,$J)
.I '$D(ZTSK) S (POP,IBABORT)=1 ;WCJ;US3880;IB641V13
.I $D(ZTSK) W !!,"This job has been queued. The task number is "_ZTSK_"."
U IO
DEVQ Q
;
QUEUE(IBFORM) ; Ask to queue transmission
N Y,DIR,OKAY
S OKAY=1
S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to queue this transmission" W !
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) S OKAY=0 G QUEQ
I 'Y D G QUEQ
.S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to run this job without queuing it now"
.W ! D ^DIR K DIR
.I 'Y S OKAY=0
; - queue job to run
W !!,"Please enter the date and time to execute this job...",!
S ZTRTN="FORMOUT^IBCEFG7",ZTIO="",ZTDESC="OUTPUT FORMATTER - FORM: "_$P($G(^IBE(353,IBFORM,0)),U),ZTSAVE("IB*")=""
S:$D(^TMP("IBRESUBMIT",$J)) ZTSAVE("^TMP(""IBRESUBMIT"",$J)")="",ZTSAVE("^TMP(""IBNOT"",$J)")="",ZTSAVE("^TMP(""IBRESUBMIT"",$J,")="",ZTSAVE("^TMP(""IBNOT"",$J,")=""
I $D(^TMP("IBSELX",$J)) S ZTSAVE("^TMP(""IBSELX"",$J,")="",ZTSAVE("^TMP(""IBSELX"",$J)")=""
D ^%ZTLOAD
I $G(ZTSK) W !!,"This job has been queued. The task number is "_ZTSK_"."
QUEQ Q OKAY
;
FPRE(IBFORM,IBPAR,IBXERR) ; Executes pre-processor
I $G(^IBE(353,IBFORM,"FPRE"))'="" X ^("FPRE") ;Form pre-processor
I $G(^IBE(353,IBFORM,"FPRE"))="",$G(^IBE(353,IBPAR,"FPRE"))'="" X ^("FPRE") ;Parent form pre-processor
Q
;
FPOST(IBFORM,IBPAR,IBXERR) ; Executes post-processor
I $G(^IBE(353,IBFORM,"FPOST"))'="" X ^("FPOST") ;Form post-processor
I $G(^IBE(353,IBFORM,"FPOST"))="",$G(^IBE(353,IBPAR,"FPOST"))'="" X ^("FPOST") ;Parent form post-processor
Q
;
FMFLD(IBDA) ;Return the file#field for fileman field referenced as a data
; element in file 364.7's IBDA entry.
N Z,Z0,ND0
S Z0=+$P($G(^IBA(364.7,IBDA,0)),U,3),ND0=$G(^IBA(364.5,+Z0,0))
I $P(ND0,U,3)'="F"!($P(ND0,U,6)="") S Z="" G FLDQ
S Z=$P(ND0,U,5),Z1=$P(ND0,U,6)
I Z1[":" D ;Navigation
. S Z2=$O(^DD(+Z,"B",$P(Z1,":"),"")) Q:'Z2
. S Z=+$P($P($G(^DD(399,Z2,0)),U,2),"P",2)
. I Z S Z1=$P(Z1,":",2)
I Z S Z=Z_"#"_$O(^DD(+Z,"B",Z1,""))
FLDQ Q Z
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEFG7 8919 printed Apr 09, 2024@21:31:17 Page 2
IBCEFG7 ;ALB/TMP - OUTPUT FORMATTER GENERIC FORM PROCESSING ;06-MAR-96
+1 ;;2.0;INTEGRATED BILLING;**52,84,96,51,137,191,320,608,641**;21-MAR-94;Build 61
+2 ;;Per VA Directive 6402, this routine should not be modified
+3 QUIT
+4 ;
+5 ;/IB*2*608 (vd) - US2486 added the parameter IBRSBTST to indicate a claim is a "TEST"
+6 ; that is being RESUBMITTED and assists with the COB Output Formatter data.
FORM(IBFORM,IBQUE,IBNOASK,IBQDT,ZTSK,IBABORT,IBRSBTST) ;For ien IBFORM, extract data using
+1 ; output generater
+2 ; IBQUE = the output queue for transmitted forms or the printer queue
+3 ; for printed output
+4 ; IBNOASK = flag that says user interaction for queuing is not needed
+5 ; 0 or null = ask, 1 = don't ask
+6 ; IBQDT = the date/time to queue the job (optional)
+7 ;
+8 ; Sets ZTSK only if job is queued
+9 ;
+10 ; IBABORT = output parameter which says user aborted forms output.
+11 ; Pass by reference. The $$QUEUE function returned false.
+12 ;
+13 ; IBRSBTST = 1, this indicates the claim is being resubmitted as a "TEST" claim and should be
+14 ; used by the OUTPUT FORMATTER entries to determine what COB information is
+15 ; going out. - IB*2.0*608 (vd) US2486
+16 ;
+17 NEW IBF2,IBTYP,POP,ZTIO,ZTRTN,ZTDESC,ZTSAVE,ZTREQ,ZTDTH,ZTREQ
+18 SET IBTYP=$PIECE($GET(^IBE(353,IBFORM,2)),U,2)
SET IBQUE=$GET(IBQUE)
SET IBABORT=0
+19 if $SELECT(IBTYP'="S"
GOTO FORMQ
+20 ;I IBTYP="P",IBQUE="" D DEV(IBFORM) G:$G(POP) FORMQ ;WCJ;US3380
+21 ;WCJ;US3380
IF IBTYP="P"
IF IBQUE=""
DO DEV(IBFORM,,.IBABORT)
if $GET(POP)
GOTO FORMQ
+22 IF IBTYP="T"
if $GET(IBNOASK)
Begin DoDot:1
+23 SET ZTRTN="FORMOUT^IBCEFG7"
SET ZTIO=""
SET ZTDESC="OUTPUT FORMATTER - FORM: "_$PIECE($GET(^IBE(353,IBFORM,0)),U)
SET ZTSAVE("IB*")=""
SET ZTDTH=$SELECT($GET(IBQDT):IBQDT,1:$$NOW^XLFDT())
+24 if $DATA(^TMP("IBRESUBMIT",$JOB))
SET ZTSAVE("^TMP(""IBRESUBMIT"",$J)")=""
SET ZTSAVE("^TMP(""IBNOT"",$J)")=""
SET ZTSAVE("^TMP(""IBRESUBMIT"",$J,")=""
SET ZTSAVE("^TMP(""IBNOT"",$J,")=""
+25 IF $DATA(^TMP("IBSELX",$JOB))
SET ZTSAVE("^TMP(""IBSELX"",$J,")=""
SET ZTSAVE("^TMP(""IBSELX"",$J)")=""
+26 if '$GET(DUZ)
SET DUZ=.5
+27 DO ^%ZTLOAD
End DoDot:1
if $GET(IBNOASK)
QUIT
IF '$$QUEUE(IBFORM)
if $ORDER(^TMP("IBRESUBMIT",$JOB,0))
SET ^TMP("IBRESUBMIT",$JOB)="ABORT"
SET IBABORT=1
QUIT
+28 IF '$GET(ZTSK)
DO FORMOUT
FORMQ QUIT
+1 ;
FORMOUT ; Queued job entrypoint - IBFORM needs to be defined
+1 ; IBQUE needs to be defined if using default transmission output
+2 NEW IB2,IBTYP,IBPAR
+3 KILL ^TMP("IBXDATA",$JOB)
+4 SET ZTREQ="@"
+5 SET IB2=$GET(^IBE(353,IBFORM,2))
SET IBPAR=+$PIECE(IB2,U,5)
SET IBTYP=$PIECE(IB2,U,2)
+6 ;
+7 ; Execute PRE-PROCESSOR
+8 IF IBTYP'="S"
DO FPRE(IBFORM,IBPAR,.IBXERR)
+9 if $GET(IBXERR)'=""
GOTO FOUTQ
+10 ;
+11 ; Extract records - this should include call(s) to $$EXTRACT^IBCEFG()
+12 IF IBTYP'="S"
Begin DoDot:1
+13 ;Form extract
IF $GET(^IBE(353,IBFORM,"EXT"))'=""
XECUTE ^("EXT")
+14 ;Parent form extract
IF $GET(^IBE(353,IBFORM,"EXT"))=""
IF $GET(^IBE(353,IBPAR,"EXT"))'=""
XECUTE ^("EXT")
End DoDot:1
+15 IF IBTYP="S"
Begin DoDot:1
+16 NEW PARAM,Z,Z0
+17 SET PARAM(1)="BILL-SEARCH"
SET Z0=$GET(^DGCR(399,IBIFN,0))
+18 SET Z=$PIECE(Z0,U,21)
if Z=""
SET Z="P"
SET PARAM(2)=$PIECE($GET(^DGCR(399,IBIFN,"I"_($FIND("PST",Z)-1))),U)
SET PARAM(3)=$SELECT($PIECE(Z0,U,5)<3:"I",1:"O")
+19 SET Z=$$EXTRACT^IBCEFG(IBFORM,IBIFN,1,.PARAM)
End DoDot:1
GOTO Q1
+20 ;
+21 if '$DATA(^TMP("IBXDATA",$JOB))
GOTO FOUTQ
+22 ;
+23 ; If an output routine exists, use it, otherwise use the generic ones
+24 IF $GET(^IBE(353,IBFORM,"OUT"))'=""
XECUTE ^("OUT")
GOTO FOUTQ
+25 IF $GET(^IBE(353,IBFORM,"OUT"))=""
IF $GET(^IBE(353,IBPAR,"OUT"))'=""
XECUTE ^("OUT")
GOTO FOUTQ
+26 ;
+27 IF IBTYP="P"
DO PRINT(IBFORM)
if '$DATA(ZTQUEUED)
DO ^%ZISC
GOTO FOUTQ
+28 IF IBTYP="T"
if $GET(IBQUE)'=""
DO TRANSMIT(IBFORM,IBQUE)
GOTO FOUTQ
+29 ;
FOUTQ ; Execute POST-PROCESSOR, if any
DO FPOST(IBFORM,IBPAR,.IBXERR)
+1 KILL ^TMP("IBXDATA",$JOB),^TMP("IBXEDIT",$JOB)
Q1 QUIT
+1 ;
PRINT(IBFORM) ; Print data from extract global for form IBFORM
+1 ; Extract records - this should include call(s) to $$EXTRACT^IBCEFG()
+2 NEW IB1,IB2,IB3,IBREC
+3 ;LOOP THROUGH RECORD/PAGE/LINE/COL
+4 ;Rec
SET IBREC=""
FOR
SET IBREC=$ORDER(^TMP("IBXDATA",$JOB,IBREC))
if IBREC=""
QUIT
Begin DoDot:1
+5 ;Page/line
+6 FOR IB1=1:1:+$ORDER(^TMP("IBXDATA",$JOB,IBREC,""),-1)
if IB1>1
WRITE @IOF
WRITE ?0
FOR IB2=1:1:+$ORDER(^TMP("IBXDATA",$JOB,IBREC,IB1,""),-1)
if IB2>1
WRITE !
SET IB3=""
Begin DoDot:2
+7 ; Column
+8 FOR
SET IB3=$ORDER(^TMP("IBXDATA",$JOB,IBREC,IB1,IB2,IB3))
if IB3=""
QUIT
WRITE ?(IB3-1),^(IB3)
End DoDot:2
+9 ;Only print form feed if more records to print - not on last record
+10 IF $ORDER(^TMP("IBXDATA",$JOB,IBREC))'=""
WRITE @IOF
End DoDot:1
+11 QUIT
+12 ;
TRANSMIT(IBFORM,IBQUE) ; Send data from extract global to queue IBQUE
+1 ;IBFORM = ien of the form to be transmitted (required)
+2 NEW IB1,IB2,IB3,IBREC,IBOUT,IBCT,IBSUB,Z,XMDUZ,XMSUBJ,XMBODY,XMTO
+3 KILL ^TMP("IBXTXMT",$JOB),^TMP("IBX",$JOB)
+4 if $GET(IBQUE)=""
QUIT
+5 ;
+6 SET IBDELIM=$PIECE($GET(^IBE(353,+$SELECT($PIECE($GET(^IBE(353,IBFORM,2)),U,5):$PIECE(^(2),U,5),1:IBFORM),2)),U,7)
+7 if IBDELIM=""
SET IBDELIM="^"
+8 ;Loop through record/page/line/column
+9 SET IBREC=""
SET (IBSIZE,IBCT)=0
SET IBMSG=1
+10 FOR
SET IBREC=$ORDER(^TMP("IBXDATA",$JOB,IBREC))
if IBREC=""
QUIT
Begin DoDot:1
+11 SET ^TMP("IBX",$JOB,IBREC)=IBCT
+12 SET IB1=""
FOR
SET IB1=$ORDER(^TMP("IBXDATA",$JOB,IBREC,IB1))
if IB1=""
QUIT
Begin DoDot:2
+13 SET (IB2,IBOUT)=""
+14 FOR
SET IB2=$ORDER(^TMP("IBXDATA",$JOB,IBREC,IB1,IB2))
if IB2=""&$LENGTH(IBOUT)
DO MSG(IBREC,IBOUT,.IBMSG,.IBSIZE,.IBCT)
if IB2=""
QUIT
Begin DoDot:3
+15 SET IB3=""
FOR
SET IB3=$ORDER(^TMP("IBXDATA",$JOB,IBREC,IB1,IB2,IB3))
if IB3=""
QUIT
SET IBP=^(IB3)
if IBP?.E1L.E
SET IBP=$$UP^XLFSTR(IBP)
SET $PIECE(IBOUT,IBDELIM,IB3)=IBP
End DoDot:3
End DoDot:2
End DoDot:1
+16 ;
+17 ;Send mail message(s) for extract
+18 SET XMDUZ=DUZ
SET XMTO(IBQUE)=""
SET IBSUB="OUTPUT FORMATTER: "_$PIECE($GET(^IBE(353,IBFORM,0)),U)
+19 SET Z=""
FOR
SET Z=$ORDER(^TMP("IBXTXMT",$JOB,Z))
if 'Z
QUIT
SET XMBODY="^TMP(""IBXTXMT"","_$JOB_","_Z_")"
SET XMSUBJ=IBSUB_" ("_Z_")"
DO SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
+20 ;
+21 KILL ^TMP("IBXTXMT",$JOB),^TMP("IBX",$JOB)
+22 QUIT
+23 ;
MSG(IBREC,LINE,MSG,SIZE,CT) ; Set up global for transmission line
+1 ; IBREC = record number being processed
+2 ; LINE = actual text to be output in mail message line
+3 ; MSG = the message seq # to output this record in (pass by reference)
+4 ; SIZE = current size of the message (pass by reference)
+5 ; CT = the last line # in message for the text (pass by reference)
+6 NEW Z,Z0,LLEN
+7 SET LLEN=$LENGTH(LINE)
+8 IF (LLEN+SIZE)>30000
Begin DoDot:1
+9 ;Record itself is > 30000 - let it go
if '$GET(^TMP("IBX",$JOB,IBREC))
QUIT
+10 SET (SIZE,CT)=0
SET Z=$GET(^TMP("IBX",$JOB,IBREC))
SET ^(IBREC)=0
+11 FOR
SET Z=$ORDER(^TMP("IBXTXMT",$JOB,MSG,Z))
if 'Z
QUIT
SET CT=CT+1
SET Z0=^(Z)
SET ^TMP("IBXTXMT",$JOB,MSG+1,CT)=Z0
SET SIZE=SIZE+$LENGTH(Z0)
KILL ^TMP("IBXTXMT",$JOB,MSG,Z)
+12 SET MSG=MSG+1
End DoDot:1
+13 SET CT=CT+1
SET ^TMP("IBXTXMT",$JOB,MSG,CT)=LINE
SET SIZE=SIZE+LLEN
+14 QUIT
+15 ;
DEV(IBFORM,NOQ,IBABORT) ;WCJ;US3380 added IBABORT
+1 NEW IBFTYPE
+2 if '$GET(NOQ)
SET %ZIS="Q"
SET %ZIS("A")="Output Device: "
+3 SET %ZIS("B")=$PIECE($GET(^IBE(353,IBFORM,0)),"^",2)
+4 DO ^%ZIS
+5 ;G:POP DEVQ;WCJ;US3880
+6 ;WCJ;US3880
IF POP
SET IBABORT=1
GOTO DEVQ
+7 IF $DATA(IO("Q"))
Begin DoDot:1
+8 SET ZTRTN="FORMOUT^IBCEFG7"
SET ZTDESC="PRINT FORM: "_$PIECE($GET(^IBE(353,IBFORM,0)),U)
SET ZTSAVE("IB*")=""
KILL ZTIO
+9 IF $DATA(^TMP("IBQONE",$JOB))
Begin DoDot:2
+10 SET IBJ=""
SET IBFTYPE="IBCFP"_$SELECT($PIECE($GET(^IBE(353,IBFORM,2)),U,5):$PIECE(^(2),U,5),1:IBFORM)
+11 SET ZTSAVE("^XTMP(IBFTYPE,$J,")=""
End DoDot:2
+12 DO ^%ZTLOAD
KILL IO("Q")
DO HOME^%ZIS
+13 IF $GET(IBFTYPE)'=""
KILL ^XTMP(IBFTYPE,$JOB)
+14 ;WCJ;US3880;IB641V13
IF '$DATA(ZTSK)
SET (POP,IBABORT)=1
+15 IF $DATA(ZTSK)
WRITE !!,"This job has been queued. The task number is "_ZTSK_"."
End DoDot:1
GOTO DEVQ
+16 USE IO
DEVQ QUIT
+1 ;
QUEUE(IBFORM) ; Ask to queue transmission
+1 NEW Y,DIR,OKAY
+2 SET OKAY=1
+3 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Do you want to queue this transmission"
WRITE !
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DTOUT)!$DATA(DUOUT)
SET OKAY=0
GOTO QUEQ
+6 IF 'Y
Begin DoDot:1
+7 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Do you want to run this job without queuing it now"
+8 WRITE !
DO ^DIR
KILL DIR
+9 IF 'Y
SET OKAY=0
End DoDot:1
GOTO QUEQ
+10 ; - queue job to run
+11 WRITE !!,"Please enter the date and time to execute this job...",!
+12 SET ZTRTN="FORMOUT^IBCEFG7"
SET ZTIO=""
SET ZTDESC="OUTPUT FORMATTER - FORM: "_$PIECE($GET(^IBE(353,IBFORM,0)),U)
SET ZTSAVE("IB*")=""
+13 if $DATA(^TMP("IBRESUBMIT",$JOB))
SET ZTSAVE("^TMP(""IBRESUBMIT"",$J)")=""
SET ZTSAVE("^TMP(""IBNOT"",$J)")=""
SET ZTSAVE("^TMP(""IBRESUBMIT"",$J,")=""
SET ZTSAVE("^TMP(""IBNOT"",$J,")=""
+14 IF $DATA(^TMP("IBSELX",$JOB))
SET ZTSAVE("^TMP(""IBSELX"",$J,")=""
SET ZTSAVE("^TMP(""IBSELX"",$J)")=""
+15 DO ^%ZTLOAD
+16 IF $GET(ZTSK)
WRITE !!,"This job has been queued. The task number is "_ZTSK_"."
QUEQ QUIT OKAY
+1 ;
FPRE(IBFORM,IBPAR,IBXERR) ; Executes pre-processor
+1 ;Form pre-processor
IF $GET(^IBE(353,IBFORM,"FPRE"))'=""
XECUTE ^("FPRE")
+2 ;Parent form pre-processor
IF $GET(^IBE(353,IBFORM,"FPRE"))=""
IF $GET(^IBE(353,IBPAR,"FPRE"))'=""
XECUTE ^("FPRE")
+3 QUIT
+4 ;
FPOST(IBFORM,IBPAR,IBXERR) ; Executes post-processor
+1 ;Form post-processor
IF $GET(^IBE(353,IBFORM,"FPOST"))'=""
XECUTE ^("FPOST")
+2 ;Parent form post-processor
IF $GET(^IBE(353,IBFORM,"FPOST"))=""
IF $GET(^IBE(353,IBPAR,"FPOST"))'=""
XECUTE ^("FPOST")
+3 QUIT
+4 ;
FMFLD(IBDA) ;Return the file#field for fileman field referenced as a data
+1 ; element in file 364.7's IBDA entry.
+2 NEW Z,Z0,ND0
+3 SET Z0=+$PIECE($GET(^IBA(364.7,IBDA,0)),U,3)
SET ND0=$GET(^IBA(364.5,+Z0,0))
+4 IF $PIECE(ND0,U,3)'="F"!($PIECE(ND0,U,6)="")
SET Z=""
GOTO FLDQ
+5 SET Z=$PIECE(ND0,U,5)
SET Z1=$PIECE(ND0,U,6)
+6 ;Navigation
IF Z1[":"
Begin DoDot:1
+7 SET Z2=$ORDER(^DD(+Z,"B",$PIECE(Z1,":"),""))
if 'Z2
QUIT
+8 SET Z=+$PIECE($PIECE($GET(^DD(399,Z2,0)),U,2),"P",2)
+9 IF Z
SET Z1=$PIECE(Z1,":",2)
End DoDot:1
+10 IF Z
SET Z=Z_"#"_$ORDER(^DD(+Z,"B",Z1,""))
FLDQ QUIT Z
+1 ;
