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