- 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 Apr 23, 2025@18:39:58 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
