IBJDF8R ;ALB/RRG - AR WORKLOAD ASSIGNMENTS (PRINT) ;05-FEB-01
;;2.0;INTEGRATED BILLING;**123,159,192,739**;21-MAR-94;Build 3
;
EN ; - Option entry point
;
CLK ; - Select one, more, or all clerks to print
W !!,"Run list for (S)pecific clerks or (A)ll clerks: ALL// "
R X:DTIME G:'$T!(X["^") ENQ S:X="" X="A" S X=$E(X)
I "SAsa"'[X S IBOFF=61 D HELP^IBJDF8H G CLK
W " ",$S("Ss"[X:"SPECIFIC",1:"ALL") G:"Aa"[X DEV K IBSI
CLK1 S DIC="^IBE(351.73,",DIC(0)="AEQMZ"
S DIC("A")=" Select "_$S($G(IBSI):"another ",1:"")_"Clerk: "
D ^DIC K DIC I Y'>0 G ENQ:'$G(IBSI),DEV
I $D(IBSI(+Y)) D G CLK1
. W !!?3,"Already selected. Choose another clerk.",!,*7
S IBSI(+Y)="" S:'$G(IBSI) IBSI=1 G CLK1
;
DEV ; - Select a device
W !!,"This report requires an 80 column printer."
S %ZIS="QM" D ^%ZIS G:POP ENQ
I $D(IO("Q")) D G ENQ
.S ZTRTN="PRINT^IBJDF8R",ZTDESC="IB - AR WORKLOAD ASSIGNMENTS LIST"
.S ZTSAVE("IB*")="" D ^%ZTLOAD
.I $G(ZTSK) W !!,"This job has been queued. The task no. is ",ZTSK,"."
.E W !!,"Unable to queue this job."
.K ZTSK,IO("Q") D HOME^%ZIS
;
U IO
;
PRINT ; - Print the AR Workload Assignments Report
;
S IBQ=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
S IBPAG=0
;
I '$D(^IBE(351.73,0)) D G ENQ
. D @("HDR")
. W !!,"There is no AR Workload Assignment information for the parameters selected."
;
S IBPAG=0 D HDR G:IBQ ENQ
;
I $G(IBSI) G PRINT1
;
; - print all clerks
;
S (IBCLNUM,IBCLNAM,IBASNUM,IBPRO,IBASNDAT,IBBCAT,IBMIN,IBSUPER,IBEXCRC)=""
; retrieve clerk detail and print
F S IBCLNUM=$O(^IBE(351.73,IBCLNUM)) Q:IBCLNUM="" D Q:IBQ
. S IBCLDAT=$G(^IBE(351.73,IBCLNUM,0)) Q:IBCLDAT=""
. S IBCLNAM=$P(^VA(200,$P(IBCLNUM,"^",1),0),"^",1),IBPRO=$P(IBCLDAT,"^",2)
. W !!!,IBCLNAM,?40,"Productivity report only? "
. W ?67,$S(IBPRO=0:"NO",1:"YES")
. I IBPRO=1 Q
. ; retrieve assignment data and print
. F S IBASNUM=$O(^IBE(351.73,IBCLNUM,1,IBASNUM)) Q:IBASNUM="" D Q:IBQ
. . S IBASNDAT=$G(^IBE(351.73,IBCLNUM,1,IBASNUM,0)) Q:IBASNDAT=""
. . S IBBCAT=$P(IBASNDAT,"^",2),IBMIN=$P(IBASNDAT,"^",3)
. . S IBSUPER=$P(IBASNDAT,"^",4),IBEXCRC=$P(IBASNDAT,"^",5)
. . W !,"Assignment #: ",?15,IBASNUM,?20,"Bill Category: "
. . W ?35,$E($P(^PRCA(430.2,IBBCAT,0),"^",1),1,18)
. . W ?55,"Min Acct Bal: ",?69,$J($FN(IBMIN,",",2),10)
. . W !,?20,"Supervisor: ",?35,$E($P($G(^VA(200,+IBSUPER,0)),"^",1),1,18)
. . W ?55,"Exclude Reg Counsel: ",?75,$S(IBEXCRC=1:"YES",1:"NO")
. . ; - Page Break
. . I $Y>(IOSL-8) D PAUSE Q:IBQ D HDR Q:IBQ
. . ; print first party parameters if present
. . I $D(^IBE(351.73,IBCLNUM,1,IBASNUM,1)) D FIRST
. . ; print third party parameters if present
. . I $D(^IBE(351.73,IBCLNUM,1,IBASNUM,2)) D THIRD
. . ;
. . ; - Page Break
. . I $Y>(IOSL-6) D PAUSE Q:IBQ D HDR Q:IBQ
. . ;
;
G ENQ:IBQ W !!,"------ End of Assignment List ------" D PAUSE
G ENQ
;
PRINT1 ; - print selected clerks only
;
S (IBCLNUM,IBCLNAM,IBASNUM,IBPRO,IBASNDAT,IBBCAT,IBMIN,IBSUPER,IBEXCRC)=""
; retrieve clerk detail and print
F S IBCLNUM=$O(IBSI(IBCLNUM)) Q:IBCLNUM="" D Q:IBQ
. S IBCLDAT=$G(^IBE(351.73,IBCLNUM,0)) Q:IBCLDAT=""
. S IBCLNAM=$P(^VA(200,$P(IBCLNUM,"^",1),0),"^",1),IBPRO=$P(IBCLDAT,"^",2)
. W !!!,IBCLNAM,?40,"Productivity report only? "
. W ?67,$S(IBPRO=0:"NO",1:"YES")
. I IBPRO=1 Q
. ; retrieve assignment data and print
. F S IBASNUM=$O(^IBE(351.73,IBCLNUM,1,IBASNUM)) Q:IBASNUM="" D
. . S IBASNDAT=$G(^IBE(351.73,IBCLNUM,1,IBASNUM,0)) Q:IBASNDAT=""
. . S IBBCAT=$P(IBASNDAT,"^",2),IBMIN=$P(IBASNDAT,"^",3)
. . S IBSUPER=$P(IBASNDAT,"^",4),IBEXCRC=$P(IBASNDAT,"^",5)
. . W !,"Assignment #: ",?15,IBASNUM,?20,"Bill Category: "
. . W ?35,$E($P(^PRCA(430.2,IBBCAT,0),"^",1),1,18)
. . W ?55,"Min Acct Bal: ",?69,$J($FN(IBMIN,",",2),10)
. . W !?20,"Supervisor: ",?35,$E($P($G(^VA(200,+IBSUPER,0)),"^",1),1,18)
. . W ?55,"Exclude Reg Counsel: ",?75,$S(IBEXCRC=1:"YES",1:"NO")
. . ; - page break
. . I $Y>(IOSL-8) D PAUSE Q:IBQ D HDR Q:IBQ
. . ; print first party parameters if present
. . I $D(^IBE(351.73,IBCLNUM,1,IBASNUM,1)) D FIRST
. . ; print third party parameters if present
. . I $D(^IBE(351.73,IBCLNUM,1,IBASNUM,2)) D THIRD
. . ; - page break
. . I $Y>(IOSL-6) D PAUSE Q:IBQ D HDR Q:IBQ
;
W !!,"------ End of Assignment List ------" D PAUSE
;
;
ENQ D ^%ZISC
K IBPAG,IBQ,%,X,Y,IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT
K IBCLNAM,IBCLNUM,IBASNUM,IBPRO,IBASNDAT,IBBCAT,IBMIN,IBSUPER
K IBEXCRC,IBFPDAT,IBTPDAT,IBTOR,IBSI,IBCLDAT,IBOFF,IBRUN
Q
;
HDR ; - Prints the Report Header
;
I IBPAG>0 W @IOF,*13
S IBPAG=$G(IBPAG)+1
W !,"AR Workload Assignments List",?35,"Run Date: ",IBRUN
W ?70,"Page: ",$J(IBPAG,3)
W !,$$DASH(IOM,0) S IBQ=$$STOP^IBOUTL("AR Workload Assignments List")
Q
;
FIRST ; - Prints First Party Parameters
;
S IBFPDAT=""
S IBFPDAT=^IBE(351.73,IBCLNUM,1,IBASNUM,1)
W !,"FIRST PARTY PARAMETERS:"
W !,"Days Since Last Payment",?38,":",?40,$P(IBFPDAT,"^",1)
W !,"First Patient Name",?38,":",?40,$P(IBFPDAT,"^",2)
W !,"Last Patient Name",?38,":",?40,$P(IBFPDAT,"^",3)
;W !,"First Social Security Number",?38,":",?40,$P(IBFPDAT,"^",4);IB*2.0*739
;W !,"Last Social Security Number",?38,":",?40,$P(IBFPDAT,"^",5);IB*2.0*739
Q
;
THIRD ; - Prints Third Party Parameters
;
S (IBTPDAT,IBTOR)=""
S IBTPDAT=^IBE(351.73,IBCLNUM,1,IBASNUM,2),IBTOR=$P(IBTPDAT,"^",8)
W !,"THIRD PARTY PARAMETERS:"
W !,"Days Since Last Transaction",?38,":",?40,$P(IBTPDAT,"^",1)
W !,"First Insurance Carrier",?38,":",?40,$P(IBTPDAT,"^",2)
W !,"Last Insurance Carrier",?38,":",?40,$P(IBTPDAT,"^",3)
W !,"First Patient Name",?38,":",?40,$P(IBTPDAT,"^",4)
W !,"Last Patient Name",?38,":",?40,$P(IBTPDAT,"^",5)
;W !,"First Social Security Number",?38,":",?40,$P(IBTPDAT,"^",6);IB*2.0*739
;W !,"Last Social Security Number",?38,":",?40,$P(IBTPDAT,"^",7);IB*2.0*739
W !,"Type of Receivable",?38,":"
W ?40,$S(IBTOR=1:"Inpatient",IBTOR=2:"Outpatient",IBTOR=3:"Pharmacy Refill",IBTOR=4:"All Receivables",1:"")
Q
;
DASH(X,Y) ; - Return a dashed line.
; Input: X=Number of Columns (80 or 132), Y=Char to be printed
;
Q $TR($J("",X)," ",$S(Y:"-",1:"="))
;
PAUSE ; - Page break.
;
I $E(IOST,1,2)'="C-" Q
N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
F IBX=$Y:1:(IOSL-3) W !
S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
Q
;
DT(X) ; - Return date.
; Input: X=Date in Fileman format
; Output: Z=Date in MMDDYY format
;
Q $E(X,4,7)_$E(X,2,3)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF8R 6541 printed Apr 09, 2024@21:32:57 Page 2
IBJDF8R ;ALB/RRG - AR WORKLOAD ASSIGNMENTS (PRINT) ;05-FEB-01
+1 ;;2.0;INTEGRATED BILLING;**123,159,192,739**;21-MAR-94;Build 3
+2 ;
EN ; - Option entry point
+1 ;
CLK ; - Select one, more, or all clerks to print
+1 WRITE !!,"Run list for (S)pecific clerks or (A)ll clerks: ALL// "
+2 READ X:DTIME
if '$TEST!(X["^")
GOTO ENQ
if X=""
SET X="A"
SET X=$EXTRACT(X)
+3 IF "SAsa"'[X
SET IBOFF=61
DO HELP^IBJDF8H
GOTO CLK
+4 WRITE " ",$SELECT("Ss"[X:"SPECIFIC",1:"ALL")
if "Aa"[X
GOTO DEV
KILL IBSI
CLK1 SET DIC="^IBE(351.73,"
SET DIC(0)="AEQMZ"
+1 SET DIC("A")=" Select "_$SELECT($GET(IBSI):"another ",1:"")_"Clerk: "
+2 DO ^DIC
KILL DIC
IF Y'>0
if '$GET(IBSI)
GOTO ENQ
GOTO DEV
+3 IF $DATA(IBSI(+Y))
Begin DoDot:1
+4 WRITE !!?3,"Already selected. Choose another clerk.",!,*7
End DoDot:1
GOTO CLK1
+5 SET IBSI(+Y)=""
if '$GET(IBSI)
SET IBSI=1
GOTO CLK1
+6 ;
DEV ; - Select a device
+1 WRITE !!,"This report requires an 80 column printer."
+2 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO ENQ
+3 IF $DATA(IO("Q"))
Begin DoDot:1
+4 SET ZTRTN="PRINT^IBJDF8R"
SET ZTDESC="IB - AR WORKLOAD ASSIGNMENTS LIST"
+5 SET ZTSAVE("IB*")=""
DO ^%ZTLOAD
+6 IF $GET(ZTSK)
WRITE !!,"This job has been queued. The task no. is ",ZTSK,"."
+7 IF '$TEST
WRITE !!,"Unable to queue this job."
+8 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
GOTO ENQ
+9 ;
+10 USE IO
+11 ;
PRINT ; - Print the AR Workload Assignments Report
+1 ;
+2 SET IBQ=0
DO NOW^%DTC
SET IBRUN=$$DAT2^IBOUTL(%)
+3 SET IBPAG=0
+4 ;
+5 IF '$DATA(^IBE(351.73,0))
Begin DoDot:1
+6 DO @("HDR")
+7 WRITE !!,"There is no AR Workload Assignment information for the parameters selected."
End DoDot:1
GOTO ENQ
+8 ;
+9 SET IBPAG=0
DO HDR
if IBQ
GOTO ENQ
+10 ;
+11 IF $GET(IBSI)
GOTO PRINT1
+12 ;
+13 ; - print all clerks
+14 ;
+15 SET (IBCLNUM,IBCLNAM,IBASNUM,IBPRO,IBASNDAT,IBBCAT,IBMIN,IBSUPER,IBEXCRC)=""
+16 ; retrieve clerk detail and print
+17 FOR
SET IBCLNUM=$ORDER(^IBE(351.73,IBCLNUM))
if IBCLNUM=""
QUIT
Begin DoDot:1
+18 SET IBCLDAT=$GET(^IBE(351.73,IBCLNUM,0))
if IBCLDAT=""
QUIT
+19 SET IBCLNAM=$PIECE(^VA(200,$PIECE(IBCLNUM,"^",1),0),"^",1)
SET IBPRO=$PIECE(IBCLDAT,"^",2)
+20 WRITE !!!,IBCLNAM,?40,"Productivity report only? "
+21 WRITE ?67,$SELECT(IBPRO=0:"NO",1:"YES")
+22 IF IBPRO=1
QUIT
+23 ; retrieve assignment data and print
+24 FOR
SET IBASNUM=$ORDER(^IBE(351.73,IBCLNUM,1,IBASNUM))
if IBASNUM=""
QUIT
Begin DoDot:2
+25 SET IBASNDAT=$GET(^IBE(351.73,IBCLNUM,1,IBASNUM,0))
if IBASNDAT=""
QUIT
+26 SET IBBCAT=$PIECE(IBASNDAT,"^",2)
SET IBMIN=$PIECE(IBASNDAT,"^",3)
+27 SET IBSUPER=$PIECE(IBASNDAT,"^",4)
SET IBEXCRC=$PIECE(IBASNDAT,"^",5)
+28 WRITE !,"Assignment #: ",?15,IBASNUM,?20,"Bill Category: "
+29 WRITE ?35,$EXTRACT($PIECE(^PRCA(430.2,IBBCAT,0),"^",1),1,18)
+30 WRITE ?55,"Min Acct Bal: ",?69,$JUSTIFY($FNUMBER(IBMIN,",",2),10)
+31 WRITE !,?20,"Supervisor: ",?35,$EXTRACT($PIECE($GET(^VA(200,+IBSUPER,0)),"^",1),1,18)
+32 WRITE ?55,"Exclude Reg Counsel: ",?75,$SELECT(IBEXCRC=1:"YES",1:"NO")
+33 ; - Page Break
+34 IF $Y>(IOSL-8)
DO PAUSE
if IBQ
QUIT
DO HDR
if IBQ
QUIT
+35 ; print first party parameters if present
+36 IF $DATA(^IBE(351.73,IBCLNUM,1,IBASNUM,1))
DO FIRST
+37 ; print third party parameters if present
+38 IF $DATA(^IBE(351.73,IBCLNUM,1,IBASNUM,2))
DO THIRD
+39 ;
+40 ; - Page Break
+41 IF $Y>(IOSL-6)
DO PAUSE
if IBQ
QUIT
DO HDR
if IBQ
QUIT
+42 ;
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+43 ;
+44 if IBQ
GOTO ENQ
WRITE !!,"------ End of Assignment List ------"
DO PAUSE
+45 GOTO ENQ
+46 ;
PRINT1 ; - print selected clerks only
+1 ;
+2 SET (IBCLNUM,IBCLNAM,IBASNUM,IBPRO,IBASNDAT,IBBCAT,IBMIN,IBSUPER,IBEXCRC)=""
+3 ; retrieve clerk detail and print
+4 FOR
SET IBCLNUM=$ORDER(IBSI(IBCLNUM))
if IBCLNUM=""
QUIT
Begin DoDot:1
+5 SET IBCLDAT=$GET(^IBE(351.73,IBCLNUM,0))
if IBCLDAT=""
QUIT
+6 SET IBCLNAM=$PIECE(^VA(200,$PIECE(IBCLNUM,"^",1),0),"^",1)
SET IBPRO=$PIECE(IBCLDAT,"^",2)
+7 WRITE !!!,IBCLNAM,?40,"Productivity report only? "
+8 WRITE ?67,$SELECT(IBPRO=0:"NO",1:"YES")
+9 IF IBPRO=1
QUIT
+10 ; retrieve assignment data and print
+11 FOR
SET IBASNUM=$ORDER(^IBE(351.73,IBCLNUM,1,IBASNUM))
if IBASNUM=""
QUIT
Begin DoDot:2
+12 SET IBASNDAT=$GET(^IBE(351.73,IBCLNUM,1,IBASNUM,0))
if IBASNDAT=""
QUIT
+13 SET IBBCAT=$PIECE(IBASNDAT,"^",2)
SET IBMIN=$PIECE(IBASNDAT,"^",3)
+14 SET IBSUPER=$PIECE(IBASNDAT,"^",4)
SET IBEXCRC=$PIECE(IBASNDAT,"^",5)
+15 WRITE !,"Assignment #: ",?15,IBASNUM,?20,"Bill Category: "
+16 WRITE ?35,$EXTRACT($PIECE(^PRCA(430.2,IBBCAT,0),"^",1),1,18)
+17 WRITE ?55,"Min Acct Bal: ",?69,$JUSTIFY($FNUMBER(IBMIN,",",2),10)
+18 WRITE !?20,"Supervisor: ",?35,$EXTRACT($PIECE($GET(^VA(200,+IBSUPER,0)),"^",1),1,18)
+19 WRITE ?55,"Exclude Reg Counsel: ",?75,$SELECT(IBEXCRC=1:"YES",1:"NO")
+20 ; - page break
+21 IF $Y>(IOSL-8)
DO PAUSE
if IBQ
QUIT
DO HDR
if IBQ
QUIT
+22 ; print first party parameters if present
+23 IF $DATA(^IBE(351.73,IBCLNUM,1,IBASNUM,1))
DO FIRST
+24 ; print third party parameters if present
+25 IF $DATA(^IBE(351.73,IBCLNUM,1,IBASNUM,2))
DO THIRD
+26 ; - page break
+27 IF $Y>(IOSL-6)
DO PAUSE
if IBQ
QUIT
DO HDR
if IBQ
QUIT
End DoDot:2
End DoDot:1
if IBQ
QUIT
+28 ;
+29 WRITE !!,"------ End of Assignment List ------"
DO PAUSE
+30 ;
+31 ;
ENQ DO ^%ZISC
+1 KILL IBPAG,IBQ,%,X,Y,IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT
+2 KILL IBCLNAM,IBCLNUM,IBASNUM,IBPRO,IBASNDAT,IBBCAT,IBMIN,IBSUPER
+3 KILL IBEXCRC,IBFPDAT,IBTPDAT,IBTOR,IBSI,IBCLDAT,IBOFF,IBRUN
+4 QUIT
+5 ;
HDR ; - Prints the Report Header
+1 ;
+2 IF IBPAG>0
WRITE @IOF,*13
+3 SET IBPAG=$GET(IBPAG)+1
+4 WRITE !,"AR Workload Assignments List",?35,"Run Date: ",IBRUN
+5 WRITE ?70,"Page: ",$JUSTIFY(IBPAG,3)
+6 WRITE !,$$DASH(IOM,0)
SET IBQ=$$STOP^IBOUTL("AR Workload Assignments List")
+7 QUIT
+8 ;
FIRST ; - Prints First Party Parameters
+1 ;
+2 SET IBFPDAT=""
+3 SET IBFPDAT=^IBE(351.73,IBCLNUM,1,IBASNUM,1)
+4 WRITE !,"FIRST PARTY PARAMETERS:"
+5 WRITE !,"Days Since Last Payment",?38,":",?40,$PIECE(IBFPDAT,"^",1)
+6 WRITE !,"First Patient Name",?38,":",?40,$PIECE(IBFPDAT,"^",2)
+7 WRITE !,"Last Patient Name",?38,":",?40,$PIECE(IBFPDAT,"^",3)
+8 ;W !,"First Social Security Number",?38,":",?40,$P(IBFPDAT,"^",4);IB*2.0*739
+9 ;W !,"Last Social Security Number",?38,":",?40,$P(IBFPDAT,"^",5);IB*2.0*739
+10 QUIT
+11 ;
THIRD ; - Prints Third Party Parameters
+1 ;
+2 SET (IBTPDAT,IBTOR)=""
+3 SET IBTPDAT=^IBE(351.73,IBCLNUM,1,IBASNUM,2)
SET IBTOR=$PIECE(IBTPDAT,"^",8)
+4 WRITE !,"THIRD PARTY PARAMETERS:"
+5 WRITE !,"Days Since Last Transaction",?38,":",?40,$PIECE(IBTPDAT,"^",1)
+6 WRITE !,"First Insurance Carrier",?38,":",?40,$PIECE(IBTPDAT,"^",2)
+7 WRITE !,"Last Insurance Carrier",?38,":",?40,$PIECE(IBTPDAT,"^",3)
+8 WRITE !,"First Patient Name",?38,":",?40,$PIECE(IBTPDAT,"^",4)
+9 WRITE !,"Last Patient Name",?38,":",?40,$PIECE(IBTPDAT,"^",5)
+10 ;W !,"First Social Security Number",?38,":",?40,$P(IBTPDAT,"^",6);IB*2.0*739
+11 ;W !,"Last Social Security Number",?38,":",?40,$P(IBTPDAT,"^",7);IB*2.0*739
+12 WRITE !,"Type of Receivable",?38,":"
+13 WRITE ?40,$SELECT(IBTOR=1:"Inpatient",IBTOR=2:"Outpatient",IBTOR=3:"Pharmacy Refill",IBTOR=4:"All Receivables",1:"")
+14 QUIT
+15 ;
DASH(X,Y) ; - Return a dashed line.
+1 ; Input: X=Number of Columns (80 or 132), Y=Char to be printed
+2 ;
+3 QUIT $TRANSLATE($JUSTIFY("",X)," ",$SELECT(Y:"-",1:"="))
+4 ;
PAUSE ; - Page break.
+1 ;
+2 IF $EXTRACT(IOST,1,2)'="C-"
QUIT
+3 NEW IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+4 FOR IBX=$Y:1:(IOSL-3)
WRITE !
+5 SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)!($DATA(DUOUT))
SET IBQ=1
+6 QUIT
+7 ;
DT(X) ; - Return date.
+1 ; Input: X=Date in Fileman format
+2 ; Output: Z=Date in MMDDYY format
+3 ;
+4 QUIT $EXTRACT(X,4,7)_$EXTRACT(X,2,3)
