- 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 Feb 18, 2025@23:37 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 ;