- 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 Feb 18, 2025@23:49:36 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)