IBOCNC2 ;ALB/ARH - CPT USAGE IN CLINICS (PRINT) ;1/23/92
;;2.0;INTEGRATED BILLING;**76,51,152**;21-MAR-94
;
START ;set up headers and dates then do appropriate print
D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S IBCDT=$P(Y,"@",1)_" "_$P(Y,"@",2)
S Y=IBBDT X ^DD("DD") S IBBDTE=Y,Y=IBEDT X ^DD("DD") S IBEDTE=Y
S IBHDR="CLINIC CPT USAGE FOR "_IBBDTE_" - "_IBEDTE
S (IBPGN,IBLN)=0,IBDSH="" F IBI=1:1:IOM S IBDSH=IBDSH_"-"
D:IBSRT=0 PRINTC D:IBSRT=1 PRINTP D:IBSRT=2 PRINTD
K IBCDT,IBBDTE,IBEDTE,IBPGN,IBLN,IBI,IBDSH,IBHDR,Y
Q
;
PRINTC ;print the report from the temp sort file to the appropriate device, by clinic
S IBLBL="W !,?3,""CLINIC"",?36,""AMBULATORY PROCEDURE"",?75,"" COUNT"",!" D HDR
S IBCLNN="" F S IBCLNN=$O(^TMP("IBCU",$J,IBCLNN)) Q:IBCLNN=""!(IBQ) D
. S IBCLN=$G(^TMP("IBCU",$J,IBCLNN,"N")),IBCP=1,IBCT=0
. S IBCPT=0 F S IBCPT=$O(^TMP("IBCU",$J,IBCLNN,IBCPT)) Q:IBCPT'?1N.N!(IBQ) D
.. S IBCPTP=$$CPT(IBCPT)
.. I (IBLN+1)>IOSL D HDR S IBCP=1
.. W !,?3,$S(IBCP:IBCLNN,1:""),?36,IBCPTP,?75,$J(^TMP("IBCU",$J,IBCLNN,IBCPT),6)
.. S IBLN=IBLN+1,IBCT=IBCT+1,IBCP=0
. I 'IBQ D:(IBLN+2)>IOSL HDR W !,?36,$E(IBDSH,1,35),?76,$E(IBDSH,1,5),!,?36,"TOTAL: ",$J(IBCT,5),?75,$J(^TMP("IBCU",$J,IBCLNN),6),!
. S IBLN=IBLN+3
D:'IBQ PAUSE
K IBCLN,IBCLNN,IBCP,IBCT,IBCPT,IBCPTP,IBLBL,X,Y
Q
;
PRINTP ;print report from temp sort file by procedure
S IBLBL="W !,""AMBULATORY PROCEDURE"",?38,"" COUNT"",?46,""#BILLED"",!" D HDR
S (IBCT,IBCPT)=0 F S IBCPT=$O(^TMP("IBCU",$J,IBCPT)) Q:IBCPT'?1N.N!(IBQ) D
. S IBCPTP=$$CPT(IBCPT)
. I (IBLN+1)>IOSL D HDR Q:IBQ
. W !,IBCPTP,?38,$J($G(^TMP("IBCU",$J,IBCPT)),6),?46,$J($G(^TMP("IBCU",$J,IBCPT,"B")),6)
. S IBLN=IBLN+1,IBCT=IBCT+1
I 'IBQ,($D(^TMP("IBCU",$J))#2!$D(^TMP("IBCU",$J,"B"))#2) D:(IBLN+2)>IOSL HDR D
. W !,$E(IBDSH,1,34),?39,$E(IBDSH,1,5),?47,$E(IBDSH,1,5),!,"TOTAL: ",$J(IBCT,6),?38,$J(+$G(^TMP("IBCU",$J)),6),?46,$J(+$G(^TMP("IBCU",$J,"B")),6)
D:'IBQ PAUSE
K IBCPT,IBCPTP,IBCT,IBLBL,X,Y
Q
;
PRINTD ;print report from temp sort file by procedure with extended description
S IBLBL="W !,""AMBULATORY PROCEDURE"",?78,"" COUNT"",?86,""#BILLED"",!" D HDR
S IBCPT=0 F S IBCPT=$O(^TMP("IBCU",$J,IBCPT)) Q:IBCPT'?1N.N!(IBQ) D
. S IBCPTP=$$CPT(IBCPT)
. D DESC I (IBLN+1)>IOSL D HDR Q:IBQ
. W !!,IBCPTP,?78,$J($G(^TMP("IBCU",$J,IBCPT)),6),?86,$J($G(^TMP("IBCU",$J,IBCPT,"B")),6)
. S IBLN=IBLN+2 I $D(IBD) S IBX=0 F S IBX=$O(IBD(IBX)) Q:IBX=""!(IBQ) D
.. D:(IBLN+1)>IOSL HDR Q:IBQ W !,?7,IBD(IBX) S IBLN=IBLN+1
D:'IBQ PAUSE
K IBCPT,IBCPTP,IBLBL,IBD,IBX,X,Y
Q
;
CPT(IBCPT) ; Format the CPT code for output
N IBICPT,IBP
S IBICPT=$$PRCD^IBCEF1(+IBCPT_";ICPT(",1)
S IBP=$J($P(IBICPT,"^",2),5)_" "_$P(IBICPT,"^",3)
Q IBP
;
DESC ;if sort by proc & user wants desc, get procedure description, store in IBD at proper length for printing
S IBDESCT=$$CPTD^ICPTCOD(IBCPT,"IBX")
Q:$G(IBDESCT)'>0
K IBD S IBY=1,IBX=0,IBLNG=68
F S IBX=$O(IBX(IBX)) Q:'IBX S IBZ=IBX(IBX) D
. F IBJ=1:1 S IBW=$P(IBZ," ",IBJ) Q:IBW="" D
.. I $L(IBW)>IBLNG S:$G(IBD(IBY))'="" IBY=IBY+1 S IBD(IBY)=$E(IBW,1,IBLNG-1)_"-",IBY=IBY+1,IBD(IBY)=$E(IBW,IBLNG,999)_" " Q
.. I ($L($G(IBD(IBY)))+$L(IBW)+1)'>IBLNG S IBD(IBY)=$G(IBD(IBY))_IBW_" " Q
.. S IBY=IBY+1,IBD(IBY)=IBW_" "
K IBY,IBX,IBLNG,IBZ,IBJ,IBW,IBDESCT
Q
;
HDR ;print the report header
S IBQ=$$STOP^IBOCNC1 Q:IBQ D:IBPGN>0 PAUSE Q:IBQ I IBPGN>0!($E(IOST,1,2)["C-") W @IOF
S IBPGN=IBPGN+1,IBLN=5 W IBHDR I IOM<85 W !
W ?(IOM-30),IBCDT,?(IOM-8),"PAGE ",IBPGN,!
I $D(IBPRC) S IBI="" F S IBI=$O(IBPRC(IBI)) Q:IBI="" W !,IBPRC(IBI) S IBLN=IBLN+1
X IBLBL F IBI=1:1:IOM W "-"
K IBI
Q
;
PAUSE ;pause at end of screen if being displayed on a terminal
Q:$E(IOST,1,2)'["C-"
S DIR(0)="E" D ^DIR K DIR I $D(DUOUT)!($D(DIRUT)) S IBQ=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOCNC2 3840 printed Oct 16, 2024@18:25:59 Page 2
IBOCNC2 ;ALB/ARH - CPT USAGE IN CLINICS (PRINT) ;1/23/92
+1 ;;2.0;INTEGRATED BILLING;**76,51,152**;21-MAR-94
+2 ;
START ;set up headers and dates then do appropriate print
+1 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
DO DD^%DT
SET IBCDT=$PIECE(Y,"@",1)_" "_$PIECE(Y,"@",2)
+2 SET Y=IBBDT
XECUTE ^DD("DD")
SET IBBDTE=Y
SET Y=IBEDT
XECUTE ^DD("DD")
SET IBEDTE=Y
+3 SET IBHDR="CLINIC CPT USAGE FOR "_IBBDTE_" - "_IBEDTE
+4 SET (IBPGN,IBLN)=0
SET IBDSH=""
FOR IBI=1:1:IOM
SET IBDSH=IBDSH_"-"
+5 if IBSRT=0
DO PRINTC
if IBSRT=1
DO PRINTP
if IBSRT=2
DO PRINTD
+6 KILL IBCDT,IBBDTE,IBEDTE,IBPGN,IBLN,IBI,IBDSH,IBHDR,Y
+7 QUIT
+8 ;
PRINTC ;print the report from the temp sort file to the appropriate device, by clinic
+1 SET IBLBL="W !,?3,""CLINIC"",?36,""AMBULATORY PROCEDURE"",?75,"" COUNT"",!"
DO HDR
+2 SET IBCLNN=""
FOR
SET IBCLNN=$ORDER(^TMP("IBCU",$JOB,IBCLNN))
if IBCLNN=""!(IBQ)
QUIT
Begin DoDot:1
+3 SET IBCLN=$GET(^TMP("IBCU",$JOB,IBCLNN,"N"))
SET IBCP=1
SET IBCT=0
+4 SET IBCPT=0
FOR
SET IBCPT=$ORDER(^TMP("IBCU",$JOB,IBCLNN,IBCPT))
if IBCPT'?1N.N!(IBQ)
QUIT
Begin DoDot:2
+5 SET IBCPTP=$$CPT(IBCPT)
+6 IF (IBLN+1)>IOSL
DO HDR
SET IBCP=1
+7 WRITE !,?3,$SELECT(IBCP:IBCLNN,1:""),?36,IBCPTP,?75,$JUSTIFY(^TMP("IBCU",$JOB,IBCLNN,IBCPT),6)
+8 SET IBLN=IBLN+1
SET IBCT=IBCT+1
SET IBCP=0
End DoDot:2
+9 IF 'IBQ
if (IBLN+2)>IOSL
DO HDR
WRITE !,?36,$EXTRACT(IBDSH,1,35),?76,$EXTRACT(IBDSH,1,5),!,?36,"TOTAL: ",$JUSTIFY(IBCT,5),?75,$JUSTIFY(^TMP("IBCU",$JOB,IBCLNN),6),!
+10 SET IBLN=IBLN+3
End DoDot:1
+11 if 'IBQ
DO PAUSE
+12 KILL IBCLN,IBCLNN,IBCP,IBCT,IBCPT,IBCPTP,IBLBL,X,Y
+13 QUIT
+14 ;
PRINTP ;print report from temp sort file by procedure
+1 SET IBLBL="W !,""AMBULATORY PROCEDURE"",?38,"" COUNT"",?46,""#BILLED"",!"
DO HDR
+2 SET (IBCT,IBCPT)=0
FOR
SET IBCPT=$ORDER(^TMP("IBCU",$JOB,IBCPT))
if IBCPT'?1N.N!(IBQ)
QUIT
Begin DoDot:1
+3 SET IBCPTP=$$CPT(IBCPT)
+4 IF (IBLN+1)>IOSL
DO HDR
if IBQ
QUIT
+5 WRITE !,IBCPTP,?38,$JUSTIFY($GET(^TMP("IBCU",$JOB,IBCPT)),6),?46,$JUSTIFY($GET(^TMP("IBCU",$JOB,IBCPT,"B")),6)
+6 SET IBLN=IBLN+1
SET IBCT=IBCT+1
End DoDot:1
+7 IF 'IBQ
IF ($DATA(^TMP("IBCU",$JOB))#2!$DATA(^TMP("IBCU",$JOB,"B"))#2)
if (IBLN+2)>IOSL
DO HDR
Begin DoDot:1
+8 WRITE !,$EXTRACT(IBDSH,1,34),?39,$EXTRACT(IBDSH,1,5),?47,$EXTRACT(IBDSH,1,5),!,"TOTAL: ",$JUSTIFY(IBCT,6),?38,$JUSTIFY(+$GET(^TMP("IBCU",$JOB)),6),?46,$JUSTIFY(+$GET(^TMP("IBCU",$JOB,"B")),6)
End DoDot:1
+9 if 'IBQ
DO PAUSE
+10 KILL IBCPT,IBCPTP,IBCT,IBLBL,X,Y
+11 QUIT
+12 ;
PRINTD ;print report from temp sort file by procedure with extended description
+1 SET IBLBL="W !,""AMBULATORY PROCEDURE"",?78,"" COUNT"",?86,""#BILLED"",!"
DO HDR
+2 SET IBCPT=0
FOR
SET IBCPT=$ORDER(^TMP("IBCU",$JOB,IBCPT))
if IBCPT'?1N.N!(IBQ)
QUIT
Begin DoDot:1
+3 SET IBCPTP=$$CPT(IBCPT)
+4 DO DESC
IF (IBLN+1)>IOSL
DO HDR
if IBQ
QUIT
+5 WRITE !!,IBCPTP,?78,$JUSTIFY($GET(^TMP("IBCU",$JOB,IBCPT)),6),?86,$JUSTIFY($GET(^TMP("IBCU",$JOB,IBCPT,"B")),6)
+6 SET IBLN=IBLN+2
IF $DATA(IBD)
SET IBX=0
FOR
SET IBX=$ORDER(IBD(IBX))
if IBX=""!(IBQ)
QUIT
Begin DoDot:2
+7 if (IBLN+1)>IOSL
DO HDR
if IBQ
QUIT
WRITE !,?7,IBD(IBX)
SET IBLN=IBLN+1
End DoDot:2
End DoDot:1
+8 if 'IBQ
DO PAUSE
+9 KILL IBCPT,IBCPTP,IBLBL,IBD,IBX,X,Y
+10 QUIT
+11 ;
CPT(IBCPT) ; Format the CPT code for output
+1 NEW IBICPT,IBP
+2 SET IBICPT=$$PRCD^IBCEF1(+IBCPT_";ICPT(",1)
+3 SET IBP=$JUSTIFY($PIECE(IBICPT,"^",2),5)_" "_$PIECE(IBICPT,"^",3)
+4 QUIT IBP
+5 ;
DESC ;if sort by proc & user wants desc, get procedure description, store in IBD at proper length for printing
+1 SET IBDESCT=$$CPTD^ICPTCOD(IBCPT,"IBX")
+2 if $GET(IBDESCT)'>0
QUIT
+3 KILL IBD
SET IBY=1
SET IBX=0
SET IBLNG=68
+4 FOR
SET IBX=$ORDER(IBX(IBX))
if 'IBX
QUIT
SET IBZ=IBX(IBX)
Begin DoDot:1
+5 FOR IBJ=1:1
SET IBW=$PIECE(IBZ," ",IBJ)
if IBW=""
QUIT
Begin DoDot:2
+6 IF $LENGTH(IBW)>IBLNG
if $GET(IBD(IBY))'=""
SET IBY=IBY+1
SET IBD(IBY)=$EXTRACT(IBW,1,IBLNG-1)_"-"
SET IBY=IBY+1
SET IBD(IBY)=$EXTRACT(IBW,IBLNG,999)_" "
QUIT
+7 IF ($LENGTH($GET(IBD(IBY)))+$LENGTH(IBW)+1)'>IBLNG
SET IBD(IBY)=$GET(IBD(IBY))_IBW_" "
QUIT
+8 SET IBY=IBY+1
SET IBD(IBY)=IBW_" "
End DoDot:2
End DoDot:1
+9 KILL IBY,IBX,IBLNG,IBZ,IBJ,IBW,IBDESCT
+10 QUIT
+11 ;
HDR ;print the report header
+1 SET IBQ=$$STOP^IBOCNC1
if IBQ
QUIT
if IBPGN>0
DO PAUSE
if IBQ
QUIT
IF IBPGN>0!($EXTRACT(IOST,1,2)["C-")
WRITE @IOF
+2 SET IBPGN=IBPGN+1
SET IBLN=5
WRITE IBHDR
IF IOM<85
WRITE !
+3 WRITE ?(IOM-30),IBCDT,?(IOM-8),"PAGE ",IBPGN,!
+4 IF $DATA(IBPRC)
SET IBI=""
FOR
SET IBI=$ORDER(IBPRC(IBI))
if IBI=""
QUIT
WRITE !,IBPRC(IBI)
SET IBLN=IBLN+1
+5 XECUTE IBLBL
FOR IBI=1:1:IOM
WRITE "-"
+6 KILL IBI
+7 QUIT
+8 ;
PAUSE ;pause at end of screen if being displayed on a terminal
+1 if $EXTRACT(IOST,1,2)'["C-"
QUIT
+2 SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)!($DATA(DIRUT))
SET IBQ=1
+3 QUIT
