IBCF ;ALB/RLW - task 1500/UB printing ;12-JUN-92
;;2.0;INTEGRATED BILLING;**33,63,52,121,51,137,349,641**;21-MAR-94;Build 61
;;Per VA Directive 6402, this routine should not be modified.
;
EN1(IBABORT) ; call appropriate print routine for the claim form type to be printed ;WCJ;US3380;ADDED IBABORT
K IBRESUB
G EN1TAG ;WCJ;US3380;added GOTO;you think of a better way
;
EN1X(IBABORT) ; Entrypoint for reprint (IBRESUB will be defined);WCJ;US3380;added parameter
;
EN1TAG N IBF,IB,IBFORM,IBJ ;WCJ;US3380; added tag;you think of a better way
S IB=$$FT^IBCU3(IBIFN) ; form type ien (2 or 3)
S IBFT=$$FTN^IBCU3(IB) ; form type name
S IBF=$P($G(^IBE(353,+IB,2)),U,8)
S:IBF="" IBF=IB ;Forces the use of the output formatter to print bills
D ENFMT(IBIFN,IB,IBF,,$G(IBRESUB),.IBABORT) ;WCJ;US3380;ADDED IBABORT
END K IBFT,IBRESUB
Q
;
EN2 ; send to default A/R device
S ZTDTH=$H,IBIFN=PRCASV("ARREC"),IBPNT=PRCASV("NOTICE")
D FORM S (IBFORM1,ZTDESC)="FOLLOW-UP AR FORM "_$P($G(^IBE(353,+IBFT,0)),"^")
D QUEUE
Q
;
EN3 ;queue an Rx Addendum for a bill, IBIFN must be defined
Q:'$D(^DGCR(399,+$G(IBIFN),0)) I '$D(^IBA(362.4,"AIFN"_+IBIFN)),'$D(^IBA(362.5,"AIFN"_+IBIFN)) Q
N IBFT S IBFT=$$FNT^IBCU3("BILL ADDENDUM") Q:'IBFT S (IBFORM1,ZTDESC)="BILL ADDENDUM FOR "_$P(^DGCR(399,+IBIFN,0),U,1)
S ZTSAVE("IB*")="",ZTDTH=$H
S ZTIO=$P($G(^IBE(353,IBFT,0)),"^",2),ZTRTN=$G(^IBE(353,IBFT,1)) I (ZTIO="")!(ZTRTN="") K ZTDESC,ZTSAVE,ZTDTH,ZTIO,ZTRTN Q
D ^%ZTLOAD
Q
;
EN4 ;queue bills, IBIFN must be defined
S ZTDTH=$H,IBPNT=1 Q:'$D(^DGCR(399,+$G(IBIFN),0))
D FORM
S IBF=$P($G(^IBE(353,+IBFT,2)),U,8)
I $P($G(^IBE(353,+IBFT,0)),U,2)="",IBF="" Q
S (IBFORM1,ZTDESC)=$P($G(^IBE(353,+IBFT,0)),"^")_" BILL "_$P(^DGCR(399,+IBIFN,0),U,1)
S ZTSAVE("IB*")=""
S ZTIO=$P($G(^IBE(353,IBFT,0)),"^",2),ZTRTN=$S(IBF="":$G(^IBE(353,IBFT,1)),1:"ENFMT^IBCF(IBIFN,IBFT,IBF,ZTIO,$G(IBRESUB))")
I (ZTIO="")!(ZTRTN="") S IBAR("ERR")="BILL FORM TYPE NOT COMPLETE FOR"_IBFORM1 Q
D ^%ZTLOAD I '$D(ZTSK) S IBAR("ERR")="QUEUEING OF "_IBFORM1_" FAILED",IBAR("OKAY")=0 W IBAR("ERR") Q
S IBAR("OKAY")=1
Q
;
EN5 ;queue 1500 Rx Addendum to Follow-up (AR) printer, IBIFN must be defined - no longer used
Q:'$D(^DGCR(399,+$G(IBIFN),0)) I '$D(^IBA(362.4,"AIFN"_+IBIFN)),'$D(^IBA(362.5,"AIFN"_+IBIFN)) Q
Q:$$FT^IBCU3(IBIFN)'=2
N IBFT S IBFT=$$FNT^IBCU3("BILL ADDENDUM") Q:'IBFT S (IBFORM1,ZTDESC)="BILL ADDENDUM FOR "_$P(^DGCR(399,+IBIFN,0),U,1)
S ZTSAVE("IB*")="",ZTDTH=$H
S ZTIO=$P($G(^IBE(353,IBFT,0)),"^",3),ZTRTN=$G(^IBE(353,IBFT,1)) I (ZTIO="")!(ZTRTN="") K ZTDESC,ZTSAVE,ZTDTH,ZTIO,ZTRTN Q
D ^%ZTLOAD
Q
;
ENFMT(IBIFN,IB,IBF,ZTIO,IBRESUB,IBABORT) ; Use formatter to print bill IBIFN
; WCJ;USS3380;added IBABORT which will be set to 1 if they went in to print but dint
N IBFT,IBFTP,IBFORM,IBJ
S (IBFT,IBFORM)=IB,IBFTP="IBCFP"_IB,IBJ=$J
K ^XTMP(IBFTP,$J),^TMP("IBQONE",$J)
S ^XTMP(IBFTP,$J,1,1,1,IBIFN)="",^TMP("IBQONE",$J)=""
;D FORM^IBCEFG7(IBF,$G(ZTIO)) ;WCJ;US3380
D FORM^IBCEFG7(IBF,$G(ZTIO),,,,.IBABORT) ;WCJ;US3380;ADDED IBABORT
I $G(IBRESUB) D
. N IBDA
. S IBDA=$$LAST364^IBCEF4(IBIFN)
. I IBDA D UPDEDI^IBCEM(IBDA,"P")
K ^TMP("IBQONE",$J)
I IBFT'=3 D EN3
Q
;
FORM ;
S IBFT=$$FT^IBCU3(IBIFN)
Q
QUEUE ;
S IBF=$P($G(^IBE(353,+IBFT,2)),U,8)
S ZTSAVE("IB*")=""
S ZTIO=$P($G(^IBE(353,IBFT,0)),"^",3),ZTRTN=$S(IBF="":$G(^IBE(353,IBFT,1)),1:"ENFMT^IBCF(IBIFN,IBFT,IBF,ZTIO,$G(IBRESUB))")
I ((ZTIO="")&(IBF=""))!(ZTRTN="") S IBAR("ERR")="BILL FORM TYPE NOT COMPLETE FOR"_IBFORM1 Q
D ^%ZTLOAD I '$D(ZTSK) S IBAR("ERR")="QUEUEING OF "_IBFORM1_" FAILED",IBAR("OKAY")=0 W IBAR("ERR") Q
S IBAR("OKAY")=1
Q
;
DISPX ; call to exclude transmittable bills
D DISP1(1)
Q
;
DISP ; call to include all bills
D DISP1(0)
Q
;
DISP1(IBTX) ;print list of authorized bills - exclude transmittables if
; IBTX=1
N IBIFN,IBC,Y
S IBIFN=0,IBC=0,Y="" W !
F S IBIFN=$O(^DGCR(399,"AST",3,IBIFN)) Q:'IBIFN S IBX=$G(^DGCR(399,IBIFN,0)) I IBX'="" D Q:Y="^"
. I $G(IBTX) D Q:IBX=""
.. N Z
.. S Z=0 F S Z=$O(^IBA(364,"B",IBIFN,Z)) Q:'Z I $D(^IBA(364,"ASTAT","X",Z)) S IBX="" Q
. W !,$P(IBX,U,1),?10,$E($P($G(^DPT(+$P(IBX,U,2),0)),U,1),1,20),?32,$$DATE^IBCFP(+$P(IBX,U,3)),?42,$S(+$P(IBX,U,5)<3:"INPT",1:"OUTPT")
. W ?49,$P($G(^DGCR(399.3,+$P(IBX,U,7),0)),U,4),?59,$E($$EXSET^IBEFUNC(+$P(IBX,U,13),399,.13),1,7),?68,$E($$FTN^IBCU3($$FT^IBCU3(IBIFN)),1,11)
. S IBC=IBC+1 I '(IBC#10) R !,"Press RETURN to continue or '^' to exit: ",Y:DTIME
Q
;
DISPT ;print list of all bills awaiting transmission
N IBI,IBIFN,IBC,Y S (IBC,IBI)=0,Y="" W !
F S IBI=$O(^IBA(364,"ASTAT","X",IBI)) Q:'IBI S IBIFN=+$G(^IBA(364,+IBI,0)),IBX=$G(^DGCR(399,IBIFN,0)) I IBX'="" D Q:Y="^"
. W !,$P(IBX,U,1),?10,$E($P($G(^DPT(+$P(IBX,U,2),0)),U,1),1,20),?32,$$DATE^IBCFP(+$P(IBX,U,3)),?42,$S(+$P(IBX,U,5)<3:"INPT",1:"OUTPT")
. W ?49,$P($G(^DGCR(399.3,+$P(IBX,U,7),0)),U,4),?59,$E($$EXSET^IBEFUNC(+$P(IBX,U,13),399,.13),1,7),?68,$E($$FTN^IBCU3($$FT^IBCU3(IBIFN)),1,11)
. S IBC=IBC+1 I '(IBC#10) R !,"Press RETURN to continue or '^' to exit: ",Y:DTIME
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCF 5169 printed Dec 13, 2024@02:12:43 Page 2
IBCF ;ALB/RLW - task 1500/UB printing ;12-JUN-92
+1 ;;2.0;INTEGRATED BILLING;**33,63,52,121,51,137,349,641**;21-MAR-94;Build 61
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN1(IBABORT) ; call appropriate print routine for the claim form type to be printed ;WCJ;US3380;ADDED IBABORT
+1 KILL IBRESUB
+2 ;WCJ;US3380;added GOTO;you think of a better way
GOTO EN1TAG
+3 ;
EN1X(IBABORT) ; Entrypoint for reprint (IBRESUB will be defined);WCJ;US3380;added parameter
+1 ;
EN1TAG ;WCJ;US3380; added tag;you think of a better way
NEW IBF,IB,IBFORM,IBJ
+1 ; form type ien (2 or 3)
SET IB=$$FT^IBCU3(IBIFN)
+2 ; form type name
SET IBFT=$$FTN^IBCU3(IB)
+3 SET IBF=$PIECE($GET(^IBE(353,+IB,2)),U,8)
+4 ;Forces the use of the output formatter to print bills
if IBF=""
SET IBF=IB
+5 ;WCJ;US3380;ADDED IBABORT
DO ENFMT(IBIFN,IB,IBF,,$GET(IBRESUB),.IBABORT)
END KILL IBFT,IBRESUB
+1 QUIT
+2 ;
EN2 ; send to default A/R device
+1 SET ZTDTH=$HOROLOG
SET IBIFN=PRCASV("ARREC")
SET IBPNT=PRCASV("NOTICE")
+2 DO FORM
SET (IBFORM1,ZTDESC)="FOLLOW-UP AR FORM "_$PIECE($GET(^IBE(353,+IBFT,0)),"^")
+3 DO QUEUE
+4 QUIT
+5 ;
EN3 ;queue an Rx Addendum for a bill, IBIFN must be defined
+1 if '$DATA(^DGCR(399,+$GET(IBIFN),0))
QUIT
IF '$DATA(^IBA(362.4,"AIFN"_+IBIFN))
IF '$DATA(^IBA(362.5,"AIFN"_+IBIFN))
QUIT
+2 NEW IBFT
SET IBFT=$$FNT^IBCU3("BILL ADDENDUM")
if 'IBFT
QUIT
SET (IBFORM1,ZTDESC)="BILL ADDENDUM FOR "_$PIECE(^DGCR(399,+IBIFN,0),U,1)
+3 SET ZTSAVE("IB*")=""
SET ZTDTH=$HOROLOG
+4 SET ZTIO=$PIECE($GET(^IBE(353,IBFT,0)),"^",2)
SET ZTRTN=$GET(^IBE(353,IBFT,1))
IF (ZTIO="")!(ZTRTN="")
KILL ZTDESC,ZTSAVE,ZTDTH,ZTIO,ZTRTN
QUIT
+5 DO ^%ZTLOAD
+6 QUIT
+7 ;
EN4 ;queue bills, IBIFN must be defined
+1 SET ZTDTH=$HOROLOG
SET IBPNT=1
if '$DATA(^DGCR(399,+$GET(IBIFN),0))
QUIT
+2 DO FORM
+3 SET IBF=$PIECE($GET(^IBE(353,+IBFT,2)),U,8)
+4 IF $PIECE($GET(^IBE(353,+IBFT,0)),U,2)=""
IF IBF=""
QUIT
+5 SET (IBFORM1,ZTDESC)=$PIECE($GET(^IBE(353,+IBFT,0)),"^")_" BILL "_$PIECE(^DGCR(399,+IBIFN,0),U,1)
+6 SET ZTSAVE("IB*")=""
+7 SET ZTIO=$PIECE($GET(^IBE(353,IBFT,0)),"^",2)
SET ZTRTN=$SELECT(IBF="":$GET(^IBE(353,IBFT,1)),1:"ENFMT^IBCF(IBIFN,IBFT,IBF,ZTIO,$G(IBRESUB))")
+8 IF (ZTIO="")!(ZTRTN="")
SET IBAR("ERR")="BILL FORM TYPE NOT COMPLETE FOR"_IBFORM1
QUIT
+9 DO ^%ZTLOAD
IF '$DATA(ZTSK)
SET IBAR("ERR")="QUEUEING OF "_IBFORM1_" FAILED"
SET IBAR("OKAY")=0
WRITE IBAR("ERR")
QUIT
+10 SET IBAR("OKAY")=1
+11 QUIT
+12 ;
EN5 ;queue 1500 Rx Addendum to Follow-up (AR) printer, IBIFN must be defined - no longer used
+1 if '$DATA(^DGCR(399,+$GET(IBIFN),0))
QUIT
IF '$DATA(^IBA(362.4,"AIFN"_+IBIFN))
IF '$DATA(^IBA(362.5,"AIFN"_+IBIFN))
QUIT
+2 if $$FT^IBCU3(IBIFN)'=2
QUIT
+3 NEW IBFT
SET IBFT=$$FNT^IBCU3("BILL ADDENDUM")
if 'IBFT
QUIT
SET (IBFORM1,ZTDESC)="BILL ADDENDUM FOR "_$PIECE(^DGCR(399,+IBIFN,0),U,1)
+4 SET ZTSAVE("IB*")=""
SET ZTDTH=$HOROLOG
+5 SET ZTIO=$PIECE($GET(^IBE(353,IBFT,0)),"^",3)
SET ZTRTN=$GET(^IBE(353,IBFT,1))
IF (ZTIO="")!(ZTRTN="")
KILL ZTDESC,ZTSAVE,ZTDTH,ZTIO,ZTRTN
QUIT
+6 DO ^%ZTLOAD
+7 QUIT
+8 ;
ENFMT(IBIFN,IB,IBF,ZTIO,IBRESUB,IBABORT) ; Use formatter to print bill IBIFN
+1 ; WCJ;USS3380;added IBABORT which will be set to 1 if they went in to print but dint
+2 NEW IBFT,IBFTP,IBFORM,IBJ
+3 SET (IBFT,IBFORM)=IB
SET IBFTP="IBCFP"_IB
SET IBJ=$JOB
+4 KILL ^XTMP(IBFTP,$JOB),^TMP("IBQONE",$JOB)
+5 SET ^XTMP(IBFTP,$JOB,1,1,1,IBIFN)=""
SET ^TMP("IBQONE",$JOB)=""
+6 ;D FORM^IBCEFG7(IBF,$G(ZTIO)) ;WCJ;US3380
+7 ;WCJ;US3380;ADDED IBABORT
DO FORM^IBCEFG7(IBF,$GET(ZTIO),,,,.IBABORT)
+8 IF $GET(IBRESUB)
Begin DoDot:1
+9 NEW IBDA
+10 SET IBDA=$$LAST364^IBCEF4(IBIFN)
+11 IF IBDA
DO UPDEDI^IBCEM(IBDA,"P")
End DoDot:1
+12 KILL ^TMP("IBQONE",$JOB)
+13 IF IBFT'=3
DO EN3
+14 QUIT
+15 ;
FORM ;
+1 SET IBFT=$$FT^IBCU3(IBIFN)
+2 QUIT
QUEUE ;
+1 SET IBF=$PIECE($GET(^IBE(353,+IBFT,2)),U,8)
+2 SET ZTSAVE("IB*")=""
+3 SET ZTIO=$PIECE($GET(^IBE(353,IBFT,0)),"^",3)
SET ZTRTN=$SELECT(IBF="":$GET(^IBE(353,IBFT,1)),1:"ENFMT^IBCF(IBIFN,IBFT,IBF,ZTIO,$G(IBRESUB))")
+4 IF ((ZTIO="")&(IBF=""))!(ZTRTN="")
SET IBAR("ERR")="BILL FORM TYPE NOT COMPLETE FOR"_IBFORM1
QUIT
+5 DO ^%ZTLOAD
IF '$DATA(ZTSK)
SET IBAR("ERR")="QUEUEING OF "_IBFORM1_" FAILED"
SET IBAR("OKAY")=0
WRITE IBAR("ERR")
QUIT
+6 SET IBAR("OKAY")=1
+7 QUIT
+8 ;
DISPX ; call to exclude transmittable bills
+1 DO DISP1(1)
+2 QUIT
+3 ;
DISP ; call to include all bills
+1 DO DISP1(0)
+2 QUIT
+3 ;
DISP1(IBTX) ;print list of authorized bills - exclude transmittables if
+1 ; IBTX=1
+2 NEW IBIFN,IBC,Y
+3 SET IBIFN=0
SET IBC=0
SET Y=""
WRITE !
+4 FOR
SET IBIFN=$ORDER(^DGCR(399,"AST",3,IBIFN))
if 'IBIFN
QUIT
SET IBX=$GET(^DGCR(399,IBIFN,0))
IF IBX'=""
Begin DoDot:1
+5 IF $GET(IBTX)
Begin DoDot:2
+6 NEW Z
+7 SET Z=0
FOR
SET Z=$ORDER(^IBA(364,"B",IBIFN,Z))
if 'Z
QUIT
IF $DATA(^IBA(364,"ASTAT","X",Z))
SET IBX=""
QUIT
End DoDot:2
if IBX=""
QUIT
+8 WRITE !,$PIECE(IBX,U,1),?10,$EXTRACT($PIECE($GET(^DPT(+$PIECE(IBX,U,2),0)),U,1),1,20),?32,$$DATE^IBCFP(+$PIECE(IBX,U,3)),?42,$SELECT(+$PIECE(IBX,U,5)<3:"INPT",1:"OUTPT")
+9 WRITE ?49,$PIECE($GET(^DGCR(399.3,+$PIECE(IBX,U,7),0)),U,4),?59,$EXTRACT($$EXSET^IBEFUNC(+$PIECE(IBX,U,13),399,.13),1,7),?68,$EXTRACT($$FTN^IBCU3($$FT^IBCU3(IBIFN)),1,11)
+10 SET IBC=IBC+1
IF '(IBC#10)
READ !,"Press RETURN to continue or '^' to exit: ",Y:DTIME
End DoDot:1
if Y="^"
QUIT
+11 QUIT
+12 ;
DISPT ;print list of all bills awaiting transmission
+1 NEW IBI,IBIFN,IBC,Y
SET (IBC,IBI)=0
SET Y=""
WRITE !
+2 FOR
SET IBI=$ORDER(^IBA(364,"ASTAT","X",IBI))
if 'IBI
QUIT
SET IBIFN=+$GET(^IBA(364,+IBI,0))
SET IBX=$GET(^DGCR(399,IBIFN,0))
IF IBX'=""
Begin DoDot:1
+3 WRITE !,$PIECE(IBX,U,1),?10,$EXTRACT($PIECE($GET(^DPT(+$PIECE(IBX,U,2),0)),U,1),1,20),?32,$$DATE^IBCFP(+$PIECE(IBX,U,3)),?42,$SELECT(+$PIECE(IBX,U,5)<3:"INPT",1:"OUTPT")
+4 WRITE ?49,$PIECE($GET(^DGCR(399.3,+$PIECE(IBX,U,7),0)),U,4),?59,$EXTRACT($$EXSET^IBEFUNC(+$PIECE(IBX,U,13),399,.13),1,7),?68,$EXTRACT($$FTN^IBCU3($$FT^IBCU3(IBIFN)),1,11)
+5 SET IBC=IBC+1
IF '(IBC#10)
READ !,"Press RETURN to continue or '^' to exit: ",Y:DTIME
End DoDot:1
if Y="^"
QUIT
+6 QUIT
+7 ;
