- IBOCNC2 ;ALB/ARH - CPT USAGE IN CLINICS (PRINT) ; 1/23/92
- ;;Version 2.0 ; INTEGRATED BILLING ;; 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"",?84,""OPC STATUS"",?114,"" CHARGE"",!" 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=$J($P($G(^ICPT(IBCPT,0)),"^",1),5)_" "_$P($G(^ICPT(IBCPT,0)),"^",2)
- .. S (IBNA,IBHCFA)="" D CPT 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),?84,IBNA,?114,$J(IBHCFA,8)
- .. 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,IBNA,IBHCFA,IBLBL,X,Y
- Q
- ;
- PRINTP ;print report from temp sort file by procedure
- S IBLBL="W !,""AMBULATORY PROCEDURE"",?38,"" COUNT"",?46,""#BILLED"",?55,""OPC STATUS"",?85,"" CHARGE"",!" D HDR
- S (IBCT,IBCPT)=0 F S IBCPT=$O(^TMP("IBCU",$J,IBCPT)) Q:IBCPT'?1N.N!(IBQ) D
- . S IBCPTP=$J($P($G(^ICPT(IBCPT,0)),"^",1),5)_" "_$P($G(^ICPT(IBCPT,0)),"^",2)
- . S (IBNA,IBHCFA)="" D CPT 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),?55,IBNA,?85,$J(IBHCFA,8)
- . 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,IBNA,IBCT,IBHCFA,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"",?95,""OPC STATUS"",?124,"" CHARGE"",!" D HDR
- S IBCPT=0 F S IBCPT=$O(^TMP("IBCU",$J,IBCPT)) Q:IBCPT'?1N.N!(IBQ) D
- . S IBCPTP=$J($P($G(^ICPT(IBCPT,0)),"^",1),5)_" "_$P($G(^ICPT(IBCPT,0)),"^",2)
- . S (IBNA,IBHCFA)="" D CPT,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),?95,IBNA,?124,$J(IBHCFA,8)
- . 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,IBNA,IBHCFA,IBLBL,IBD,IBX,X,Y
- Q
- ;
- CPT ;get CPT status and charge data
- S D0=IBCPT S IBNA=$P(^DD(409.71,205,0),"^",5,999) X IBNA S IBNA=X
- S X=$$CPTBSTAT^IBEFUNC1(IBCPT,DT),IBHCFA=$P(X,"^",2)
- I +X S IBHCFA=$$CPTCHG^IBEFUNC1(IBCPT,$S($D(IBCLN):$P($G(^SC(+IBCLN,0)),"^",15),1:""),DT),IBHCFA=$J(IBHCFA,8,2)
- K D0,X
- Q
- ;
- DESC ;if sort by proc & user wants desc, get procedure description, store in IBD at proper length for printing
- Q:'$D(^ICPT(IBCPT,"D")) K IBD S IBY=1,IBX=0,IBLNG=68
- F S IBX=$O(^ICPT(IBCPT,"D",IBX)) Q:IBX'?1N.N S IBZ=$G(^ICPT(IBCPT,"D",IBX,0)) 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
- 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
- IBOCNC2 ;ALB/ARH - CPT USAGE IN CLINICS (PRINT) ; 1/23/92
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 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"",?84,""OPC STATUS"",?114,"" CHARGE"",!"
- 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=$JUSTIFY($PIECE($GET(^ICPT(IBCPT,0)),"^",1),5)_" "_$PIECE($GET(^ICPT(IBCPT,0)),"^",2)
- +6 SET (IBNA,IBHCFA)=""
- DO CPT
- 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),?84,IBNA,?114,$JUSTIFY(IBHCFA,8)
- +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,IBNA,IBHCFA,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"",?55,""OPC STATUS"",?85,"" CHARGE"",!"
- 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=$JUSTIFY($PIECE($GET(^ICPT(IBCPT,0)),"^",1),5)_" "_$PIECE($GET(^ICPT(IBCPT,0)),"^",2)
- +4 SET (IBNA,IBHCFA)=""
- DO CPT
- 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),?55,IBNA,?85,$JUSTIFY(IBHCFA,8)
- +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,IBNA,IBCT,IBHCFA,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"",?95,""OPC STATUS"",?124,"" CHARGE"",!"
- 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=$JUSTIFY($PIECE($GET(^ICPT(IBCPT,0)),"^",1),5)_" "_$PIECE($GET(^ICPT(IBCPT,0)),"^",2)
- +4 SET (IBNA,IBHCFA)=""
- DO CPT
- 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),?95,IBNA,?124,$JUSTIFY(IBHCFA,8)
- +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,IBNA,IBHCFA,IBLBL,IBD,IBX,X,Y
- +10 QUIT
- +11 ;
- CPT ;get CPT status and charge data
- +1 SET D0=IBCPT
- SET IBNA=$PIECE(^DD(409.71,205,0),"^",5,999)
- XECUTE IBNA
- SET IBNA=X
- +2 SET X=$$CPTBSTAT^IBEFUNC1(IBCPT,DT)
- SET IBHCFA=$PIECE(X,"^",2)
- +3 IF +X
- SET IBHCFA=$$CPTCHG^IBEFUNC1(IBCPT,$SELECT($DATA(IBCLN):$PIECE($GET(^SC(+IBCLN,0)),"^",15),1:""),DT)
- SET IBHCFA=$JUSTIFY(IBHCFA,8,2)
- +4 KILL D0,X
- +5 QUIT
- +6 ;
- DESC ;if sort by proc & user wants desc, get procedure description, store in IBD at proper length for printing
- +1 IF '$DATA(^ICPT(IBCPT,"D"))
- QUIT
- KILL IBD
- SET IBY=1
- SET IBX=0
- SET IBLNG=68
- +2 FOR
- SET IBX=$ORDER(^ICPT(IBCPT,"D",IBX))
- IF IBX'?1N.N
- QUIT
- SET IBZ=$GET(^ICPT(IBCPT,"D",IBX,0))
- Begin DoDot:1
- +3 FOR IBJ=1:1
- SET IBW=$PIECE(IBZ," ",IBJ)
- IF IBW=""
- QUIT
- Begin DoDot:2
- +4 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
- +5 IF ($LENGTH($GET(IBD(IBY)))+$LENGTH(IBW)+1)'>IBLNG
- SET IBD(IBY)=$GET(IBD(IBY))_IBW_" "
- QUIT
- +6 SET IBY=IBY+1
- SET IBD(IBY)=IBW_" "
- End DoDot:2
- End DoDot:1
- +7 KILL IBY,IBX,IBLNG,IBZ,IBJ,IBW
- +8 QUIT
- +9 ;
- 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