Routine: IBCFP

IBCFP	;ALB/ARH - PRINT AUTHORIZED BILLS IN ORDER ; 6-DEC-94

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;;Per VHA Directive 10-93-142, this routine should not be modified.

	S IBPAR1=$G(^IBE(350.9,1,1))

	S IBFT=$G(^IBE(353,+$P(IBPAR1,U,26),0)) I $P(IBFT,U,2)="" W !,"Default printer in billing not defined for the "_$P(IBFT,U,1)_", none will print!",!

	I +$P(IBPAR1,U,22),$P($G(^IBE(353,+$$FNT^IBCU3("HCFA 1500"),0)),U,2)="" W !,"Default printer in billing not defined for the HCFA 1500, none will print!",!

	I '$D(^DGCR(399,"AST")) W !,"There are no Authorized but not Printed bills to print!" G END

	S IBS="",IBZ="Z:ZIP;I:INSURANCE COMPANY NAME;P:PATIENT NAME;"

ORDER	S DIR("?")="This option prints all bills with a Status of Authorized in the order requested.  The printed bills may be sorted by: Zip Code, Insurance Company Name, and Patient name."

1	S DIR("A")="First Sort Bills By",DIR(0)="SOB^"_IBZ D ^DIR I $D(DIRUT) G END

	S IBS=IBS_$S(Y="Z":1,Y="I":2,Y="P":3,1:0) S IBX=$P($P(IBZ,Y_":",2),";",1)

	S DIR("?",1)="Enter the field that the bills should be sorted on within "_IBX_".  Press return if the order already entered is sufficient.",DIR("?",2)=""

2	S DIR("A")="Then Sort Bills By",DIR(0)="SOB^"_IBZ D ^DIR I Y'="",$D(DIRUT) G END

	S IBS=IBS_$S(Y="Z":1,Y="I":2,Y="P":3,1:0) G:Y="" BEG S IBY=$P($P(IBZ,Y_":",2),";",1)

	S DIR("?",1)="Enter the field that the bills should be sorted on within "_IBX_" and "_IBY_".  Press return if the order already entered is sufficient."

3	S DIR("A")="Then Sort Bills By",DIR(0)="SOB^"_IBZ D ^DIR K DIR I Y'="",$D(DIRUT) G END

	S IBS=IBS_$S(Y="Z":1,Y="I":2,Y="P":3,1:0)

BEG	S DIR("A")="Begin printing bills",DIR("?")="Enter 'Y'es to begin printing of all authorized bills."

	W ! S DIR(0)="YBO",DIR("??")="^D DISP^IBCF" D ^DIR K DIR I 'Y W "... bills not printed!" G END

	S ZTRTN="QTASK^IBCFP",ZTDESC="BATCH PRINT AUTHORIZED THIRD PARTY BILLS",ZTIO="",ZTSAVE("IBS")="" D ^%ZTLOAD

	I $D(ZTSK) W !," ... queued"

END	K DIR,IBX,IBY,IBZ,IBS,IBPAR1,IBFT,Y,X,DIRUT ; end of interactive part

QTASK	; first part, sorts authorized bills in to order requested by bill form type then queues off one job for each form type to print the bills

SORT	;sort authorized bills by form type and requested sort order (notice that bill addendums only print for HCFA 1500's)

	S (IBQ,IBIFN)=0 F  S IBIFN=$O(^DGCR(399,"AST",3,IBIFN)) Q:'IBIFN!IBQ  D  I $$STOP S IBQ=1 Q

	. S IBFT=$$FT^IBCU3(IBIFN)

	. S IBX=$G(^DGCR(399,IBIFN,0)),IBPAT=$P($G(^DPT(+$P(IBX,U,2),0)),U,1) Q:$P(IBX,U,13)'=3

	. S IBX=$G(^DGCR(399,IBIFN,"M")),IBZIP=$P(IBX,U,9),IBINS=$P($G(^DIC(36,+IBX,0)),U,1)

	. S IBX=IBZIP_U_IBINS_U_IBPAT,IBS1=$P(IBX,U,$E(IBS,1))_" ",IBS2=$P(IBX,U,$E(IBS,2))_" ",IBS3=$P(IBX,U,$E(IBS,3))_" "

	. S ^TMP("IBCFP"_IBFT,$J,IBS1,IBS2,IBS3,IBIFN)="" Q:$$FTN^IBCU3(IBFT)'["HCFA 1500"

	. S IBFT=$$FNT^IBCU3("BILL ADDENDUM") I +IBFT S ^TMP("IBCFP"_IBFT,$J,IBS1,IBS2,IBS3,IBIFN)=""

	K IBIFN,IBFT,IBX,IBY,IBPAT,IBZIP,IBINS,IBS1,IBS2,IBS3,IBS

QUEUE	; starts a queued job for each form type that an authorized bill was found for

	; first checks that a device has been defined for the form type

	I 'IBQ S IBX="IBCFP" F  S IBX=$O(^TMP(IBX)) Q:(IBX'?1"IBCFP"1N)  Q:($O(^TMP(IBX,0))'=$J)  S IBFT=$E(IBX,6) D

	. S ZTIO=$P($G(^IBE(353,+IBFT,0)),U,2) Q:ZTIO=""  S IBFTP=IBX,IBJ=$J

	. S ZTDTH=$H,ZTSAVE("IBFTP")="",ZTSAVE("IBFT")="",ZTSAVE("IBJ")="",ZTSAVE("^TMP(IBFTP,IBJ,")=""

	. S ZTDESC="BATCH PRINTING "_$$FTN^IBCU3(+IBFT),ZTRTN="QBILL^IBCFP" D ^%ZTLOAD

	K IBX,IBY,IBFTP,IBJ ; end of first queued part

QBILL	; second queued part, this will print all authorized bills for a specific form type

	; pass in IBFTP="IBCFP"_(form type) and "^TMP(IBFTP,$J)" sorted array of bills

	S (IBQ,IBS1)=0 F  S IBS1=$O(^TMP(IBFTP,IBJ,IBS1)) Q:IBS1=""!IBQ  D

	. S IBS2=0 F  S IBS2=$O(^TMP(IBFTP,IBJ,IBS1,IBS2)) Q:IBS2=""!IBQ  D

	.. S IBS3=0 F  S IBS3=$O(^TMP(IBFTP,IBJ,IBS1,IBS2,IBS3)) Q:IBS3=""!IBQ  D

	... S IBBN=0 F  S IBBN=$O(^TMP(IBFTP,IBJ,IBS1,IBS2,IBS3,IBBN)) Q:IBBN=""  D  I $$STOP S IBQ=1 Q

	.... D ROUT(IBFT,1,IBBN)

	K ^TMP(IBFTP,IBJ),IBJ,IBFT,IBFTP,IBL,IBIFN,IBBN,IBPNT,IBQ ; end of last queued part

ROUT(IBFT,IBPNT,IBIFN)	; sub procedure so can protect variables with new

	N IBBN,IBS1,IBS2,IBS3,IBQ,IBFTP,IBJ

	I IBFT=1 S DFN=$P($G(^DGCR(399,+IBIFN,0)),U,2) D ENP^IBCF1 W @IOF G RE

	I IBFT=2 D EN^IBCF2 W @IOF G RE

	I $$FTN^IBCU3(+IBFT)="UB-92" D EN^IBCF3 W @IOF G RE

	I $$FTN^IBCU3(+IBFT)="BILL ADDENDUM" I +$$BILLAD^IBCF4(IBIFN) D EN^IBCF4 W @IOF G RE

RE	Q

DATE(X)	Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)

STOP()	;determine if user has requested the queued report to stop

	I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***"

	Q +$G(ZTSTOP)

IBCFP     ;ALB/ARH - PRINT AUTHORIZED BILLS IN ORDER ; 6-DEC-94

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4       ;

 +5        SET IBPAR1=$GET(^IBE(350.9,1,1))

 +6        SET IBFT=$GET(^IBE(353,+$PIECE(IBPAR1,U,26),0))

           IF $PIECE(IBFT,U,2)=""

               WRITE !,"Default printer in billing not defined for the "_$PIECE(IBFT,U,1)_", none will print!",!

 +7        IF +$PIECE(IBPAR1,U,22)

               IF $PIECE($GET(^IBE(353,+$$FNT^IBCU3("HCFA 1500"),0)),U,2)=""

                   WRITE !,"Default printer in billing not defined for the HCFA 1500, none will print!",!

 +8        IF '$DATA(^DGCR(399,"AST"))

               WRITE !,"There are no Authorized but not Printed bills to print!"

               GOTO END

 +9       ;

 +10       SET IBS=""

           SET IBZ="Z:ZIP;I:INSURANCE COMPANY NAME;P:PATIENT NAME;"

ORDER      SET DIR("?")="This option prints all bills with a Status of Authorized in the order requested.  The printed bills may be sorted by: Zip Code, Insurance Company Name, and Patient name."

1          SET DIR("A")="First Sort Bills By"

           SET DIR(0)="SOB^"_IBZ

           DO ^DIR

           IF $DATA(DIRUT)

               GOTO END

 +1        SET IBS=IBS_$SELECT(Y="Z":1,Y="I":2,Y="P":3,1:0)

           SET IBX=$PIECE($PIECE(IBZ,Y_":",2),";",1)

 +2       ;

 +3        SET DIR("?",1)="Enter the field that the bills should be sorted on within "_IBX_".  Press return if the order already entered is sufficient."

           SET DIR("?",2)=""

2          SET DIR("A")="Then Sort Bills By"

           SET DIR(0)="SOB^"_IBZ

           DO ^DIR

           IF Y'=""

               IF $DATA(DIRUT)

                   GOTO END

 +1        SET IBS=IBS_$SELECT(Y="Z":1,Y="I":2,Y="P":3,1:0)

           IF Y=""

               GOTO BEG

           SET IBY=$PIECE($PIECE(IBZ,Y_":",2),";",1)

 +2       ;

 +3        SET DIR("?",1)="Enter the field that the bills should be sorted on within "_IBX_" and "_IBY_".  Press return if the order already entered is sufficient."

3          SET DIR("A")="Then Sort Bills By"

           SET DIR(0)="SOB^"_IBZ

           DO ^DIR

           KILL DIR

           IF Y'=""

               IF $DATA(DIRUT)

                   GOTO END

 +1        SET IBS=IBS_$SELECT(Y="Z":1,Y="I":2,Y="P":3,1:0)

 +2       ;

BEG        SET DIR("A")="Begin printing bills"

           SET DIR("?")="Enter 'Y'es to begin printing of all authorized bills."

 +1        WRITE !

           SET DIR(0)="YBO"

           SET DIR("??")="^D DISP^IBCF"

           DO ^DIR

           KILL DIR

           IF 'Y

               WRITE "... bills not printed!"

               GOTO END

 +2       ;

 +3        SET ZTRTN="QTASK^IBCFP"

           SET ZTDESC="BATCH PRINT AUTHORIZED THIRD PARTY BILLS"

           SET ZTIO=""

           SET ZTSAVE("IBS")=""

           DO ^%ZTLOAD

 +4        IF $DATA(ZTSK)

               WRITE !," ... queued"

 +5       ;

END       ; end of interactive part

           KILL DIR,IBX,IBY,IBZ,IBS,IBPAR1,IBFT,Y,X,DIRUT

 +1        QUIT

 +2       ;

QTASK     ; first part, sorts authorized bills in to order requested by bill form type then queues off one job for each form type to print the bills

 +1       ;

SORT      ;sort authorized bills by form type and requested sort order (notice that bill addendums only print for HCFA 1500's)

 +1        SET (IBQ,IBIFN)=0

FOR

               SET IBIFN=$ORDER(^DGCR(399,"AST",3,IBIFN))

               IF 'IBIFN!IBQ

                   QUIT

               Begin DoDot:1

 +2                SET IBFT=$$FT^IBCU3(IBIFN)

 +3                SET IBX=$GET(^DGCR(399,IBIFN,0))

                   SET IBPAT=$PIECE($GET(^DPT(+$PIECE(IBX,U,2),0)),U,1)

                   IF $PIECE(IBX,U,13)'=3

                       QUIT

 +4                SET IBX=$GET(^DGCR(399,IBIFN,"M"))

                   SET IBZIP=$PIECE(IBX,U,9)

                   SET IBINS=$PIECE($GET(^DIC(36,+IBX,0)),U,1)

 +5                SET IBX=IBZIP_U_IBINS_U_IBPAT

                   SET IBS1=$PIECE(IBX,U,$EXTRACT(IBS,1))_" "

                   SET IBS2=$PIECE(IBX,U,$EXTRACT(IBS,2))_" "

                   SET IBS3=$PIECE(IBX,U,$EXTRACT(IBS,3))_" "

 +6                SET ^TMP("IBCFP"_IBFT,$JOB,IBS1,IBS2,IBS3,IBIFN)=""

                   IF $$FTN^IBCU3(IBFT)'["HCFA 1500"

                       QUIT

 +7                SET IBFT=$$FNT^IBCU3("BILL ADDENDUM")

                   IF +IBFT

                       SET ^TMP("IBCFP"_IBFT,$JOB,IBS1,IBS2,IBS3,IBIFN)=""

               End DoDot:1

               IF $$STOP

                   SET IBQ=1

                   QUIT

 +8        KILL IBIFN,IBFT,IBX,IBY,IBPAT,IBZIP,IBINS,IBS1,IBS2,IBS3,IBS

 +9       ;

QUEUE     ; starts a queued job for each form type that an authorized bill was found for

 +1       ; first checks that a device has been defined for the form type

 +2        IF 'IBQ

               SET IBX="IBCFP"

FOR

                   SET IBX=$ORDER(^TMP(IBX))

                   IF (IBX'?1"IBCFP"1N)

                       QUIT

                   IF ($ORDER(^TMP(IBX,0))'=$JOB)

                       QUIT

                   SET IBFT=$EXTRACT(IBX,6)

                   Begin DoDot:1

 +3                    SET ZTIO=$PIECE($GET(^IBE(353,+IBFT,0)),U,2)

                       IF ZTIO=""

                           QUIT

                       SET IBFTP=IBX

                       SET IBJ=$JOB

 +4                    SET ZTDTH=$HOROLOG

                       SET ZTSAVE("IBFTP")=""

                       SET ZTSAVE("IBFT")=""

                       SET ZTSAVE("IBJ")=""

                       SET ZTSAVE("^TMP(IBFTP,IBJ,")=""

 +5                    SET ZTDESC="BATCH PRINTING "_$$FTN^IBCU3(+IBFT)

                       SET ZTRTN="QBILL^IBCFP"

                       DO ^%ZTLOAD

                   End DoDot:1

 +6       ; end of first queued part

           KILL IBX,IBY,IBFTP,IBJ

 +7        QUIT

 +8       ;

 +9       ;

QBILL     ; second queued part, this will print all authorized bills for a specific form type

 +1       ; pass in IBFTP="IBCFP"_(form type) and "^TMP(IBFTP,$J)" sorted array of bills

 +2        SET (IBQ,IBS1)=0

FOR

               SET IBS1=$ORDER(^TMP(IBFTP,IBJ,IBS1))

               IF IBS1=""!IBQ

                   QUIT

               Begin DoDot:1

 +3                SET IBS2=0

FOR

                       SET IBS2=$ORDER(^TMP(IBFTP,IBJ,IBS1,IBS2))

                       IF IBS2=""!IBQ

                           QUIT

                       Begin DoDot:2

 +4                        SET IBS3=0

FOR

                               SET IBS3=$ORDER(^TMP(IBFTP,IBJ,IBS1,IBS2,IBS3))

                               IF IBS3=""!IBQ

                                   QUIT

                               Begin DoDot:3

 +5                                SET IBBN=0

FOR

                                       SET IBBN=$ORDER(^TMP(IBFTP,IBJ,IBS1,IBS2,IBS3,IBBN))

                                       IF IBBN=""

                                           QUIT

                                       Begin DoDot:4

 +6                                        DO ROUT(IBFT,1,IBBN)

                                       End DoDot:4

                                       IF $$STOP

                                           SET IBQ=1

                                           QUIT

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +7       ; end of last queued part

           KILL ^TMP(IBFTP,IBJ),IBJ,IBFT,IBFTP,IBL,IBIFN,IBBN,IBPNT,IBQ

 +8        QUIT

 +9       ;

ROUT(IBFT,IBPNT,IBIFN) ; sub procedure so can protect variables with new

 +1        NEW IBBN,IBS1,IBS2,IBS3,IBQ,IBFTP,IBJ

 +2        IF IBFT=1

               SET DFN=$PIECE($GET(^DGCR(399,+IBIFN,0)),U,2)

               DO ENP^IBCF1

               WRITE @IOF

               GOTO RE

 +3        IF IBFT=2

               DO EN^IBCF2

               WRITE @IOF

               GOTO RE

 +4        IF $$FTN^IBCU3(+IBFT)="UB-92"

               DO EN^IBCF3

               WRITE @IOF

               GOTO RE

 +5        IF $$FTN^IBCU3(+IBFT)="BILL ADDENDUM"

               IF +$$BILLAD^IBCF4(IBIFN)

                   DO EN^IBCF4

                   WRITE @IOF

                   GOTO RE

RE         QUIT

 +1       ;

DATE(X)    QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)

 +1       ;

STOP()    ;determine if user has requested the queued report to stop

 +1        IF $DATA(ZTQUEUED)

               IF $$S^%ZTLOAD

                   SET ZTSTOP=1

                   KILL ZTREQ

                   IF +$GET(IBPGN)

                       WRITE !,"***TASK STOPPED BY USER***"

 +2        QUIT +$GET(ZTSTOP)

IBCFP.m