SCRPW15 ;RENO/KEITH - Encounter Activity Report (Cont.) ;06/19/99
;;5.3;Scheduling;**139,144,166,180,295,593**;AUG 13, 1993;Build 13
;06/19/99 ACS - Added CPT modifiers to the report
;06/19/99 ACS - Added CPT modifier API calls
;
N LINEFLAG
S SDIV="" F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:SDIV=""!SDOUT D DCAL
S SDLINE="",$P(SDLINE,"-",81)="" D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),(SDPAGE,SDFFS)=1
S SDIV="" F S SDIV=$O(SDDIV(SDIV)) Q:'SDIV S SDIV(SDDIV(SDIV))=SDIV
I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE()
I $P(SDDIV,U,2)="ALL DIVISIONS" S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI S SDX=$P($G(^DG(40.8,SDI,0)),U) S:$L(SDX) SDIV(SDX)=SDI
D:$E(IOST)="C" DISP0^SCRPW23 I '$O(^TMP("SCRPW",$J,0)) S SDIV=0 D DHDR^SCRPW40(2,.SDT) D HDR() Q:SDOUT S SDX="No activity found within selected report parameters!" W !!?(80-$L(SDX)\2),SDX G EXIT
S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT S SDIV=SDIV(SDIVN) D DPRT(.SDIV)
S SDI=0,SDI=$O(^TMP("SCRPW",$J,SDI)),SDMD=$O(^TMP("SCRPW",$J,SDI))
G:SDOUT EXIT I SDMD S SDIV=0 D DPRT(.SDIV)
;
I $E(IOST)="C",'$G(SDOUT) N DIR S DIR(0)="E" D ^DIR
EXIT K SD,SDDIV G EXIT^SCRPW14
;
DCAL ;Calculate numbers for a division
D STOP^SCRPW14 Q:SDOUT
S SDS=0 F S SDS=$O(^TMP("SCRPW",$J,SDIV,1,SDS)) Q:'SDS D S1 S ^TMP("SCRPW",$J,SDIV,1,SDS,"VIS")=SDVS(SDIV),^TMP("SCRPW",$J,SDIV,1,SDS,"UNIQ")=SDUN(SDIV),^TMP("SCRPW",$J,SDIV,2,$$ORD(),SDS)=""
S (SDRPVS(SDIV),SDRPUN(SDIV),DFN)=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,"RPT","PT",DFN)) Q:'DFN S SDRPUN(SDIV)=SDRPUN(SDIV)+1,SDDT=0 F S SDDT=$O(^TMP("SCRPW",$J,SDIV,"RPT","PT",DFN,SDDT)) Q:'SDDT S SDRPVS(SDIV)=SDRPVS(SDIV)+1
Q
;
DPRT(SDIV) ;Print report for a division
S:SD("FMT")="D" SDDET=1 D T3 S SDPAGE=1 I '$D(^TMP("SCRPW",$J,SDIV)) S SDX="No activity found for this division!" D HDR() Q:SDOUT W !!?(80-$L(SDX)\2),SDX Q
D HDR() Q:SDOUT
S SDSV="" F S SDSV=$O(^TMP("SCRPW",$J,SDIV,2,SDSV),$S(SD("ORD")="A":1,1:-1)) Q:SDSV=""!SDOUT S SDS=0 F S SDS=$O(^TMP("SCRPW",$J,SDIV,2,SDSV,SDS)) Q:'SDS!SDOUT D PRT
Q:SDOUT I SD("FMT")="S" D RTOT Q
Q:SDOUT D:SD("FMT")="D" NONE Q
;
S1 S (SDVS(SDIV),SDUN(SDIV),SDPT)=0 F S SDPT=$O(^TMP("SCRPW",$J,SDIV,1,SDS,"PT",SDPT)) Q:'SDPT S SDUN(SDIV)=SDUN(SDIV)+1,SDDT=0 F S SDDT=$O(^TMP("SCRPW",$J,SDIV,1,SDS,"PT",SDPT,SDDT)) Q:'SDDT S SDVS(SDIV)=SDVS(SDIV)+1
Q:SD("FMT")="S"
S SDD=0 F S SDD=$O(^TMP("SCRPW",$J,SDIV,1,SDS,"DX",SDD)) Q:'SDD S SDTOT=$G(^TMP("SCRPW",$J,SDIV,1,SDS,"DX",SDD,"PRI"))+$G(^TMP("SCRPW",$J,SDIV,1,SDS,"DX",SDD,"SEC")),^TMP("SCRPW",$J,SDIV,1,SDS,"DXTOT",SDTOT,SDD)=""
S SDP=0 F S SDP=$O(^TMP("SCRPW",$J,SDIV,1,SDS,"PROC",SDP)) Q:'SDP S SDTOT=^TMP("SCRPW",$J,SDIV,1,SDS,"PROC",SDP),^TMP("SCRPW",$J,SDIV,1,SDS,"PROCTOT",SDTOT,SDP)=""
Q
;
ORD() ;Produce sort value
Q:SD("ORD")="V" SDVS(SDIV) Q:SD("ORD")="U" SDUN(SDIV) Q:SD("ORD")="E" ^TMP("SCRPW",$J,SDIV,1,SDS,"ENC") Q $$SNAME()
;
HDR(SDPG) ;Print page header
D STOP^SCRPW14 Q:SDOUT
I $E(IOST)="C",'SDFFS N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
S:$G(SDPG) SDPAGE=+SDPG W:'SDFFS $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE,!?22,"<*> ENCOUNTER ACTIVITY REPORT <*>"
N SDI S SDI=0 F S SDI=$O(SDTIT(SDI)) Q:'SDI W !?(80-$L(SDTIT(SDI))\2),SDTIT(SDI)
I SDPAGE=1 W !,SDLINE D PVIEW(15,1)
W !,SDLINE,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1,SDFFS=0
Q:'$D(^TMP("SCRPW",$J,SDIV))
Q:$G(SDPG)["N" I SD("FMT")="D",SDPAGE>2 W !,$S(SD("CAT")="C":"Clinic: ",SD("CAT")="P":"Provider: ",1:"Stop Code: "),$$SNAME()," (cont.)",! Q
W !,$S(SD("CAT")="C":"Clinic",SD("CAT")="P":"Provider",1:"Stop Code"),?40,"Encounters",?59,"Visits",?73,"Uniques",!,"------------------------------------",?40,"----------",?55,"----------",?70,"----------"
Q
;
RTOT ;Print report total
D:$Y>(IOSL-5) HDR() Q:SDOUT W !!,"====================================",?40,"==========",?55,"==========",?70,"==========",!!,"REPORT TOTAL:",?40,$J(SDRPEN(SDIV),10),?55,$J(SDRPVS(SDIV),10),?70,$J(SDRPUN(SDIV),10) Q
;
T3 K SDTIT D DHDR^SCRPW40(1,.SDTIT) Q
;
PVIEW(SDCOL,SDSKIP) ;Print report parameters
;Required input: SDCOL=column to position output
;Required input: SDSKIP=1 to skip division data on output
D:'$G(SDSKIP) PDIV W !?SDCOL," Activity date range: " S Y=SD("BDT") X ^DD("DD") W Y," to " S Y=$P(SD("EDT"),".") X ^DD("DD") W Y
W !?(SDCOL+8),"Report category: ",$S(SD("CAT")="C":"CLINIC",SD("CAT")="P":"PROVIDER",1:"STOP CODE")," perspective",!?(SDCOL+10),"Output format: ",$S(SD("FMT")="S":"SUMMARY",1:"DETAIL")
I SD("FMT")="S" W !?(SDCOL+8),"Collation order: ",$S(SD("ORD")="A":"ALPHABETIC",SD("ORD")="E":"by ENCOUNTER TOTAL",SD("ORD")="V":"by VISIT TOTAL",1:"by UNIQUE TOTAL")
W !?(SDCOL+7),"Encounter status: " S X=$O(SD("STAT",0)) W $P(^SD(409.63,X,0),U) F S X=$O(SD("STAT",X)) Q:'X W !?(SDCOL+25),$P(^SD(409.63,X,0),U)
Q
;
PDIV I 'SDDIV W !?SDCOL,"Medical Center Division: ",$P(SDDIV,U,2) Q
N SDI S SDI=0 F S SDI=$O(SDDIV(SDI)) Q:'SDI W !?SDCOL,"Medical Center Division: ",SDDIV(SDI)
Q
;
SNAME() ;Produce item name
Q:SD("CAT")="C" $P($G(^SC(SDS,0),"UNKNOWN"),U) Q:SD("CAT")="P" $P($G(^VA(200,SDS,0),"UNKNOWN"),U)
N X S X=$G(^DIC(40.7,SDS,0),"UNKNOWN^UNKNOWN"),X=$P(X,U,2)_" - "_$P(X,U) Q X
;
PRT ;Print data
I SD("FMT")="D",'$G(SDDET) D HDR(1) Q:SDOUT
D:$Y>(IOSL-4) HDR() Q:SDOUT K SDDET W !,$$SNAME(),?40,$J(^TMP("SCRPW",$J,SDIV,1,SDS,"ENC"),10),?55,$J(^TMP("SCRPW",$J,SDIV,1,SDS,"VIS"),10),?70,$J(^TMP("SCRPW",$J,SDIV,1,SDS,"UNIQ"),10) I SD("FMT")="D" D DX Q:SDOUT D PROC
Q
;
DX ;Print diagnosis information
D DXHD I '$D(^TMP("SCRPW",$J,SDIV,1,SDS,"DX")) W !!,"(No diagnosis information identified)" Q
S (SDT,SDTOT,SDTOT1,SDTOT2)="" F S SDT=$O(^TMP("SCRPW",$J,SDIV,1,SDS,"DXTOT",SDT),-1) Q:SDT=""!SDOUT S SDD=0 F S SDD=$O(^TMP("SCRPW",$J,SDIV,1,SDS,"DXTOT",SDT,SDD)) Q:'SDD!SDOUT D DX1
Q:SDOUT
W !,"====================================",?40,"==========",?55,"==========",?70,"==========",!,"TOTAL:",?40,$J(SDTOT1,10),?55,$J(SDTOT2,10),?70,$J(SDTOT,10) Q
;
DX1 ;
N SDDIAG,DIWL,DIWF,SDL2 S DIWL=1 S DIWF="C36|"
D:$Y>(IOSL-6) HDR(),DXHD Q:SDOUT
S SDD0=$$ICDDX^SCRPWICD(SDD) S SDDIAG=$P(SDD0,U,2)_" "_$P(SDD0,U,4)
S SDT1=+$G(^TMP("SCRPW",$J,SDIV,1,SDS,"DX",SDD,"PRI"))
S SDT2=+$G(^TMP("SCRPW",$J,SDIV,1,SDS,"DX",SDD,"SEC"))
S SDTOT1=SDTOT1+SDT1 S SDTOT2=SDTOT2+SDT2 S SDTOT=SDTOT+SDT1+SDT2
K ^UTILITY($J,"W") S X=SDDIAG D ^DIWP
F SDL2=1:1:^UTILITY($J,"W",DIWL) W !,$E(^UTILITY($J,"W",DIWL,SDL2,0),1,36)
W ?40,$J(SDT1,10),?55,$J(SDT2,10),?70,$J((SDT1+SDT2),10)
Q
;
DXHD ;Diagnosis sub-header
Q:SDOUT W !!,"Diagnosis",?43,"Primary",?56,"Secondary",?75,"Total",!,"------------------------------------",?40,"----------",?55,"----------",?70,"----------" Q
;
PROC ;Print procedure information
D:$Y>(IOSL-8) HDR() Q:SDOUT D PROCHD I '$D(^TMP("SCRPW",$J,SDIV,1,SDS,"PROC")) W !!?12,"(No procedure information identified)" Q
S (SDT,SDTOT)="" F S SDT=$O(^TMP("SCRPW",$J,SDIV,1,SDS,"PROCTOT",SDT),-1) Q:SDT=""!SDOUT S SDP=0 F S SDP=$O(^TMP("SCRPW",$J,SDIV,1,SDS,"PROCTOT",SDT,SDP)) Q:'SDP!SDOUT D PROC1
Q:SDOUT
W !?12,"===================================",?55,"==========",!?12,"PROCEDURE TOTAL:",?55,$J(SDTOT,10) Q
;
PROC1 ;D:$Y>(IOSL-6) HDR(),PROCHD Q:SDOUT S SDP0=^ICPT(SDP,0),SDTOT=SDTOT+SDT W !?12,$P(SDP0,U),?18,$P(SDP0,U,2),?55,$J(SDT,10) Q
N CPTCODE,CPTTEXT,SDMOD,SDMODQTY
D:$Y>(IOSL-6) HDR(),PROCHD Q:SDOUT
S SDP0=$$CPT^ICPTCOD(SDP,,1)
Q:SDP0'>0
S CPTCODE=$P(SDP0,U,2)
S CPTTEXT=$P(SDP0,U,3)
S SDTOT=SDTOT+SDT
;print procedure, desc, quantity
I LINEFLAG W !
W !?12,CPTCODE,?18,CPTTEXT,?55,$J(SDT,10)
S LINEFLAG=1
;build array to hold ranked modifiers
K ^TMP("SCRPW",$J,SDIV,1,SDS,"PROC",2)
S SDMOD=""
S SDPROC=SDP
F S SDMOD=$O(^TMP("SCRPW",$J,SDIV,1,SDS,"PROC",SDPROC,SDMOD)) Q:SDMOD="" D
. S SDMODQTY=$G(^TMP("SCRPW",$J,SDIV,1,SDS,"PROC",SDPROC,SDMOD))
. S ^TMP("SCRPW",$J,SDIV,1,SDS,"PROC",2,SDMODQTY,SDMOD)=""
. Q
; loop through ranked modifiers
S SDMODQTY=""
F S SDMODQTY=$O(^TMP("SCRPW",$J,SDIV,1,SDS,"PROC",2,SDMODQTY),-1) Q:SDMODQTY="" D
. S SDMOD=""
. F S SDMOD=$O(^TMP("SCRPW",$J,SDIV,1,SDS,"PROC",2,SDMODQTY,SDMOD),-1) Q:SDMOD="" D
.. D:$Y>(IOSL-6) HDR(),PROCHD Q:SDOUT
.. N MODINFO,MODCODE,MODTEXT,SDMQTY2
.. S MODINFO=$$MOD^ICPTMOD(SDMOD,"I",,1)
.. I +MODINFO'>0 Q
.. S MODCODE=$P(MODINFO,"^",2)
.. ; format for printing
.. S MODCODE=$S($L(MODCODE)=1:" "_MODCODE,1:" "_MODCODE)
.. S MODTEXT=$E($P(MODINFO,"^",3),1,32)
.. ;print modifier, desc, and quantity
.. S SDMQTY2="-"_SDMODQTY
.. W !,?13,"-",MODCODE,?18,MODTEXT,?55,$J(SDMQTY2,10)
.. Q
. S LINEFLAG=1
. Q
K ^TMP("SCRPW",$J,SDIV,1,SDS,"PROC",2)
Q
;
PROCHD S LINEFLAG=0 Q:SDOUT W !!?12,"Procedures/Modifiers",?60,"Total",!?12,"--------------------------------------",?55,"----------" Q
;
NONE ;List items with no activity
S SDS=0 F S SDS=$O(SD("LIST",SDS)) Q:'SDS!SDOUT I '$D(^TMP("SCRPW",$J,SDIV,1,SDS)) S SDN=1 D HDR("1N") Q
I $G(SDN) S SDS=0 F S SDS=$O(SD("LIST",SDS)) Q:'SDS!SDOUT I '$D(^TMP("SCRPW",$J,SDIV,1,SDS)) D:$Y>(IOSL-4) HDR("N") Q:SDOUT D NO1
Q
;
NO1 W !!,"No activity found for ",$S(SD("CAT")="C":"clinic",SD("CAT")="P":"provider",1:"stop code"),": ",$$SNAME() Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW15 9363 printed Dec 13, 2024@02:43:19 Page 2
SCRPW15 ;RENO/KEITH - Encounter Activity Report (Cont.) ;06/19/99
+1 ;;5.3;Scheduling;**139,144,166,180,295,593**;AUG 13, 1993;Build 13
+2 ;06/19/99 ACS - Added CPT modifiers to the report
+3 ;06/19/99 ACS - Added CPT modifier API calls
+4 ;
+5 NEW LINEFLAG
+6 SET SDIV=""
FOR
SET SDIV=$ORDER(^TMP("SCRPW",$JOB,SDIV))
if SDIV=""!SDOUT
QUIT
DO DCAL
+7 SET SDLINE=""
SET $PIECE(SDLINE,"-",81)=""
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET SDPNOW=$PIECE(Y,":",1,2)
SET (SDPAGE,SDFFS)=1
+8 SET SDIV=""
FOR
SET SDIV=$ORDER(SDDIV(SDIV))
if 'SDIV
QUIT
SET SDIV(SDDIV(SDIV))=SDIV
+9 IF 'SDDIV
IF $PIECE(SDDIV,U,2)'="ALL DIVISIONS"
SET SDIV($PIECE(SDDIV,U,2))=$$PRIM^VASITE()
+10 IF $PIECE(SDDIV,U,2)="ALL DIVISIONS"
SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDI))
if 'SDI
QUIT
SET SDX=$PIECE($GET(^DG(40.8,SDI,0)),U)
if $LENGTH(SDX)
SET SDIV(SDX)=SDI
+11 if $EXTRACT(IOST)="C"
DO DISP0^SCRPW23
IF '$ORDER(^TMP("SCRPW",$JOB,0))
SET SDIV=0
DO DHDR^SCRPW40(2,.SDT)
DO HDR()
if SDOUT
QUIT
SET SDX="No activity found within selected report parameters!"
WRITE !!?(80-$LENGTH(SDX)\2),SDX
GOTO EXIT
+12 SET SDIVN=""
FOR
SET SDIVN=$ORDER(SDIV(SDIVN))
if SDIVN=""!SDOUT
QUIT
SET SDIV=SDIV(SDIVN)
DO DPRT(.SDIV)
+13 SET SDI=0
SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDI))
SET SDMD=$ORDER(^TMP("SCRPW",$JOB,SDI))
+14 if SDOUT
GOTO EXIT
IF SDMD
SET SDIV=0
DO DPRT(.SDIV)
+15 ;
+16 IF $EXTRACT(IOST)="C"
IF '$GET(SDOUT)
NEW DIR
SET DIR(0)="E"
DO ^DIR
EXIT KILL SD,SDDIV
GOTO EXIT^SCRPW14
+1 ;
DCAL ;Calculate numbers for a division
+1 DO STOP^SCRPW14
if SDOUT
QUIT
+2 SET SDS=0
FOR
SET SDS=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDS))
if 'SDS
QUIT
DO S1
SET ^TMP("SCRPW",$JOB,SDIV,1,SDS,"VIS")=SDVS(SDIV)
SET ^TMP("SCRPW",$JOB,SDIV,1,SDS,"UNIQ")=SDUN(SDIV)
SET ^TMP("SCRPW",$JOB,SDIV,2,$$ORD(),SDS)=""
+3 SET (SDRPVS(SDIV),SDRPUN(SDIV),DFN)=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,SDIV,"RPT","PT",DFN))
if 'DFN
QUIT
SET SDRPUN(SDIV)=SDRPUN(SDIV)+1
SET SDDT=0
FOR
SET SDDT=$ORDER(^TMP("SCRPW",$JOB,SDIV,"RPT","PT",DFN,SDDT))
if 'SDDT
QUIT
SET SDRPVS(SDIV)=SDRPVS(SDIV)+1
+4 QUIT
+5 ;
DPRT(SDIV) ;Print report for a division
+1 if SD("FMT")="D"
SET SDDET=1
DO T3
SET SDPAGE=1
IF '$DATA(^TMP("SCRPW",$JOB,SDIV))
SET SDX="No activity found for this division!"
DO HDR()
if SDOUT
QUIT
WRITE !!?(80-$LENGTH(SDX)\2),SDX
QUIT
+2 DO HDR()
if SDOUT
QUIT
+3 SET SDSV=""
FOR
SET SDSV=$ORDER(^TMP("SCRPW",$JOB,SDIV,2,SDSV),$SELECT(SD("ORD")="A":1,1:-1))
if SDSV=""!SDOUT
QUIT
SET SDS=0
FOR
SET SDS=$ORDER(^TMP("SCRPW",$JOB,SDIV,2,SDSV,SDS))
if 'SDS!SDOUT
QUIT
DO PRT
+4 if SDOUT
QUIT
IF SD("FMT")="S"
DO RTOT
QUIT
+5 if SDOUT
QUIT
if SD("FMT")="D"
DO NONE
QUIT
+6 ;
S1 SET (SDVS(SDIV),SDUN(SDIV),SDPT)=0
FOR
SET SDPT=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDS,"PT",SDPT))
if 'SDPT
QUIT
SET SDUN(SDIV)=SDUN(SDIV)+1
SET SDDT=0
FOR
SET SDDT=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDS,"PT",SDPT,SDDT))
if 'SDDT
QUIT
SET SDVS(SDIV)=SDVS(SDIV)+1
+1 if SD("FMT")="S"
QUIT
+2 SET SDD=0
FOR
SET SDD=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDS,"DX",SDD))
if 'SDD
QUIT
SET SDTOT=$GET(^TMP("SCRPW",$JOB,SDIV,1,SDS,"DX",SDD,"PRI"))+$GET(^TMP("SCRPW",$JOB,SDIV,1,SDS,"DX",SDD,"SEC"))
SET ^TMP("SCRPW",$JOB,SDIV,1,SDS,"DXTOT",SDTOT,SDD)=""
+3 SET SDP=0
FOR
SET SDP=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDS,"PROC",SDP))
if 'SDP
QUIT
SET SDTOT=^TMP("SCRPW",$JOB,SDIV,1,SDS,"PROC",SDP)
SET ^TMP("SCRPW",$JOB,SDIV,1,SDS,"PROCTOT",SDTOT,SDP)=""
+4 QUIT
+5 ;
ORD() ;Produce sort value
+1 if SD("ORD")="V"
QUIT SDVS(SDIV)
if SD("ORD")="U"
QUIT SDUN(SDIV)
if SD("ORD")="E"
QUIT ^TMP("SCRPW",$JOB,SDIV,1,SDS,"ENC")
QUIT $$SNAME()
+2 ;
HDR(SDPG) ;Print page header
+1 DO STOP^SCRPW14
if SDOUT
QUIT
+2 IF $EXTRACT(IOST)="C"
IF 'SDFFS
NEW DIR
SET DIR(0)="E"
DO ^DIR
SET SDOUT=Y'=1
if SDOUT
QUIT
+3 if $GET(SDPG)
SET SDPAGE=+SDPG
if 'SDFFS
WRITE $$XY^SCRPW50(IOF,1,0)
if $X
WRITE $$XY^SCRPW50("",0,0)
WRITE SDLINE,!?22,"<*> ENCOUNTER ACTIVITY REPORT <*>"
+4 NEW SDI
SET SDI=0
FOR
SET SDI=$ORDER(SDTIT(SDI))
if 'SDI
QUIT
WRITE !?(80-$LENGTH(SDTIT(SDI))\2),SDTIT(SDI)
+5 IF SDPAGE=1
WRITE !,SDLINE
DO PVIEW(15,1)
+6 WRITE !,SDLINE,!,"Date printed: ",SDPNOW,?(74-$LENGTH(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,!
SET SDPAGE=SDPAGE+1
SET SDFFS=0
+7 if '$DATA(^TMP("SCRPW",$JOB,SDIV))
QUIT
+8 if $GET(SDPG)["N"
QUIT
IF SD("FMT")="D"
IF SDPAGE>2
WRITE !,$SELECT(SD("CAT")="C":"Clinic: ",SD("CAT")="P":"Provider: ",1:"Stop Code: "),$$SNAME()," (cont.)",!
QUIT
+9 WRITE !,$SELECT(SD("CAT")="C":"Clinic",SD("CAT")="P":"Provider",1:"Stop Code"),?40,"Encounters",?59,"Visits",?73,"Uniques",!,"------------------------------------",?40,"----------",?55,"----------",?70,"----------"
+10 QUIT
+11 ;
RTOT ;Print report total
+1 if $Y>(IOSL-5)
DO HDR()
if SDOUT
QUIT
WRITE !!,"====================================",?40,"==========",?55,"==========",?70,"==========",!!,"REPORT TOTAL:",?40,$JUSTIFY(SDRPEN(SDIV),10),?55,$JUSTIFY(SDRPVS(SDIV),10),?70,$JUSTIFY(SDRPUN(SDIV),10)
QUIT
+2 ;
T3 KILL SDTIT
DO DHDR^SCRPW40(1,.SDTIT)
QUIT
+1 ;
PVIEW(SDCOL,SDSKIP) ;Print report parameters
+1 ;Required input: SDCOL=column to position output
+2 ;Required input: SDSKIP=1 to skip division data on output
+3 if '$GET(SDSKIP)
DO PDIV
WRITE !?SDCOL," Activity date range: "
SET Y=SD("BDT")
XECUTE ^DD("DD")
WRITE Y," to "
SET Y=$PIECE(SD("EDT"),".")
XECUTE ^DD("DD")
WRITE Y
+4 WRITE !?(SDCOL+8),"Report category: ",$SELECT(SD("CAT")="C":"CLINIC",SD("CAT")="P":"PROVIDER",1:"STOP CODE")," perspective",!?(SDCOL+10),"Output format: ",$SELECT(SD("FMT")="S":"SUMMARY",1:"DETAIL")
+5 IF SD("FMT")="S"
WRITE !?(SDCOL+8),"Collation order: ",$SELECT(SD("ORD")="A":"ALPHABETIC",SD("ORD")="E":"by ENCOUNTER TOTAL",SD("ORD")="V":"by VISIT TOTAL",1:"by UNIQUE TOTAL")
+6 WRITE !?(SDCOL+7),"Encounter status: "
SET X=$ORDER(SD("STAT",0))
WRITE $PIECE(^SD(409.63,X,0),U)
FOR
SET X=$ORDER(SD("STAT",X))
if 'X
QUIT
WRITE !?(SDCOL+25),$PIECE(^SD(409.63,X,0),U)
+7 QUIT
+8 ;
PDIV IF 'SDDIV
WRITE !?SDCOL,"Medical Center Division: ",$PIECE(SDDIV,U,2)
QUIT
+1 NEW SDI
SET SDI=0
FOR
SET SDI=$ORDER(SDDIV(SDI))
if 'SDI
QUIT
WRITE !?SDCOL,"Medical Center Division: ",SDDIV(SDI)
+2 QUIT
+3 ;
SNAME() ;Produce item name
+1 if SD("CAT")="C"
QUIT $PIECE($GET(^SC(SDS,0),"UNKNOWN"),U)
if SD("CAT")="P"
QUIT $PIECE($GET(^VA(200,SDS,0),"UNKNOWN"),U)
+2 NEW X
SET X=$GET(^DIC(40.7,SDS,0),"UNKNOWN^UNKNOWN")
SET X=$PIECE(X,U,2)_" - "_$PIECE(X,U)
QUIT X
+3 ;
PRT ;Print data
+1 IF SD("FMT")="D"
IF '$GET(SDDET)
DO HDR(1)
if SDOUT
QUIT
+2 if $Y>(IOSL-4)
DO HDR()
if SDOUT
QUIT
KILL SDDET
WRITE !,$$SNAME(),?40,$JUSTIFY(^TMP("SCRPW",$JOB,SDIV,1,SDS,"ENC"),10),?55,$JUSTIFY(^TMP("SCRPW",$JOB,SDIV,1,SDS,"VIS"),10),?70,$JUSTIFY(^TMP("SCRPW",$JOB,SDIV,1,SDS,"UNIQ"),10)
IF SD("FMT")="D"
DO DX
if SDOUT
QUIT
DO PROC
+3 QUIT
+4 ;
DX ;Print diagnosis information
+1 DO DXHD
IF '$DATA(^TMP("SCRPW",$JOB,SDIV,1,SDS,"DX"))
WRITE !!,"(No diagnosis information identified)"
QUIT
+2 SET (SDT,SDTOT,SDTOT1,SDTOT2)=""
FOR
SET SDT=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDS,"DXTOT",SDT),-1)
if SDT=""!SDOUT
QUIT
SET SDD=0
FOR
SET SDD=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDS,"DXTOT",SDT,SDD))
if 'SDD!SDOUT
QUIT
DO DX1
+3 if SDOUT
QUIT
+4 WRITE !,"====================================",?40,"==========",?55,"==========",?70,"==========",!,"TOTAL:",?40,$JUSTIFY(SDTOT1,10),?55,$JUSTIFY(SDTOT2,10),?70,$JUSTIFY(SDTOT,10)
QUIT
+5 ;
DX1 ;
+1 NEW SDDIAG,DIWL,DIWF,SDL2
SET DIWL=1
SET DIWF="C36|"
+2 if $Y>(IOSL-6)
DO HDR()
DO DXHD
if SDOUT
QUIT
+3 SET SDD0=$$ICDDX^SCRPWICD(SDD)
SET SDDIAG=$PIECE(SDD0,U,2)_" "_$PIECE(SDD0,U,4)
+4 SET SDT1=+$GET(^TMP("SCRPW",$JOB,SDIV,1,SDS,"DX",SDD,"PRI"))
+5 SET SDT2=+$GET(^TMP("SCRPW",$JOB,SDIV,1,SDS,"DX",SDD,"SEC"))
+6 SET SDTOT1=SDTOT1+SDT1
SET SDTOT2=SDTOT2+SDT2
SET SDTOT=SDTOT+SDT1+SDT2
+7 KILL ^UTILITY($JOB,"W")
SET X=SDDIAG
DO ^DIWP
+8 FOR SDL2=1:1:^UTILITY($JOB,"W",DIWL)
WRITE !,$EXTRACT(^UTILITY($JOB,"W",DIWL,SDL2,0),1,36)
+9 WRITE ?40,$JUSTIFY(SDT1,10),?55,$JUSTIFY(SDT2,10),?70,$JUSTIFY((SDT1+SDT2),10)
+10 QUIT
+11 ;
DXHD ;Diagnosis sub-header
+1 if SDOUT
QUIT
WRITE !!,"Diagnosis",?43,"Primary",?56,"Secondary",?75,"Total",!,"------------------------------------",?40,"----------",?55,"----------",?70,"----------"
QUIT
+2 ;
PROC ;Print procedure information
+1 if $Y>(IOSL-8)
DO HDR()
if SDOUT
QUIT
DO PROCHD
IF '$DATA(^TMP("SCRPW",$JOB,SDIV,1,SDS,"PROC"))
WRITE !!?12,"(No procedure information identified)"
QUIT
+2 SET (SDT,SDTOT)=""
FOR
SET SDT=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDS,"PROCTOT",SDT),-1)
if SDT=""!SDOUT
QUIT
SET SDP=0
FOR
SET SDP=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDS,"PROCTOT",SDT,SDP))
if 'SDP!SDOUT
QUIT
DO PROC1
+3 if SDOUT
QUIT
+4 WRITE !?12,"===================================",?55,"==========",!?12,"PROCEDURE TOTAL:",?55,$JUSTIFY(SDTOT,10)
QUIT
+5 ;
PROC1 ;D:$Y>(IOSL-6) HDR(),PROCHD Q:SDOUT S SDP0=^ICPT(SDP,0),SDTOT=SDTOT+SDT W !?12,$P(SDP0,U),?18,$P(SDP0,U,2),?55,$J(SDT,10) Q
+1 NEW CPTCODE,CPTTEXT,SDMOD,SDMODQTY
+2 if $Y>(IOSL-6)
DO HDR()
DO PROCHD
if SDOUT
QUIT
+3 SET SDP0=$$CPT^ICPTCOD(SDP,,1)
+4 if SDP0'>0
QUIT
+5 SET CPTCODE=$PIECE(SDP0,U,2)
+6 SET CPTTEXT=$PIECE(SDP0,U,3)
+7 SET SDTOT=SDTOT+SDT
+8 ;print procedure, desc, quantity
+9 IF LINEFLAG
WRITE !
+10 WRITE !?12,CPTCODE,?18,CPTTEXT,?55,$JUSTIFY(SDT,10)
+11 SET LINEFLAG=1
+12 ;build array to hold ranked modifiers
+13 KILL ^TMP("SCRPW",$JOB,SDIV,1,SDS,"PROC",2)
+14 SET SDMOD=""
+15 SET SDPROC=SDP
+16 FOR
SET SDMOD=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDS,"PROC",SDPROC,SDMOD))
if SDMOD=""
QUIT
Begin DoDot:1
+17 SET SDMODQTY=$GET(^TMP("SCRPW",$JOB,SDIV,1,SDS,"PROC",SDPROC,SDMOD))
+18 SET ^TMP("SCRPW",$JOB,SDIV,1,SDS,"PROC",2,SDMODQTY,SDMOD)=""
+19 QUIT
End DoDot:1
+20 ; loop through ranked modifiers
+21 SET SDMODQTY=""
+22 FOR
SET SDMODQTY=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDS,"PROC",2,SDMODQTY),-1)
if SDMODQTY=""
QUIT
Begin DoDot:1
+23 SET SDMOD=""
+24 FOR
SET SDMOD=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDS,"PROC",2,SDMODQTY,SDMOD),-1)
if SDMOD=""
QUIT
Begin DoDot:2
+25 if $Y>(IOSL-6)
DO HDR()
DO PROCHD
if SDOUT
QUIT
+26 NEW MODINFO,MODCODE,MODTEXT,SDMQTY2
+27 SET MODINFO=$$MOD^ICPTMOD(SDMOD,"I",,1)
+28 IF +MODINFO'>0
QUIT
+29 SET MODCODE=$PIECE(MODINFO,"^",2)
+30 ; format for printing
+31 SET MODCODE=$SELECT($LENGTH(MODCODE)=1:" "_MODCODE,1:" "_MODCODE)
+32 SET MODTEXT=$EXTRACT($PIECE(MODINFO,"^",3),1,32)
+33 ;print modifier, desc, and quantity
+34 SET SDMQTY2="-"_SDMODQTY
+35 WRITE !,?13,"-",MODCODE,?18,MODTEXT,?55,$JUSTIFY(SDMQTY2,10)
+36 QUIT
End DoDot:2
+37 SET LINEFLAG=1
+38 QUIT
End DoDot:1
+39 KILL ^TMP("SCRPW",$JOB,SDIV,1,SDS,"PROC",2)
+40 QUIT
+41 ;
PROCHD SET LINEFLAG=0
if SDOUT
QUIT
WRITE !!?12,"Procedures/Modifiers",?60,"Total",!?12,"--------------------------------------",?55,"----------"
QUIT
+1 ;
NONE ;List items with no activity
+1 SET SDS=0
FOR
SET SDS=$ORDER(SD("LIST",SDS))
if 'SDS!SDOUT
QUIT
IF '$DATA(^TMP("SCRPW",$JOB,SDIV,1,SDS))
SET SDN=1
DO HDR("1N")
QUIT
+2 IF $GET(SDN)
SET SDS=0
FOR
SET SDS=$ORDER(SD("LIST",SDS))
if 'SDS!SDOUT
QUIT
IF '$DATA(^TMP("SCRPW",$JOB,SDIV,1,SDS))
if $Y>(IOSL-4)
DO HDR("N")
if SDOUT
QUIT
DO NO1
+3 QUIT
+4 ;
NO1 WRITE !!,"No activity found for ",$SELECT(SD("CAT")="C":"clinic",SD("CAT")="P":"provider",1:"stop code"),": ",$$SNAME()
QUIT
