SCRPW28 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 12/5/00 4:44pm
;;5.3;Scheduling;**144,232,562**;AUG 13, 1993;Build 7
PDF ;Print delimited format
S (SDOUT,SDSTOP)=0 D RPAR,RSUM,RDET G EXIT^SCRPW27
;
RPAR W !,$$BRK("Report Parameters") Q:SDOUT
W !,"TYPE^CATEGORY^SUB-CATEGORY^VALUE^METHOD^INCLUDE/EXCLUDE"
S SDI=0 F S SDI=$O(SDPAR("F",SDI)) Q:'SDI W !,"FORMAT^",$P($T(F+SDI^SCRPW22),";;",2),"^(none)^",$P(SDPAR("F",SDI),U,2),"^^"
D ITEM("P",1) F SDI=1,2 W !,"LIMITATION^",$P($T(L+SDI^SCRPW22),";;",2),"^(none)^",$P(SDPAR("L",SDI),U,2),"^^"
S SDI=2 F S SDI=$O(SDPAR("L",SDI)) Q:'SDI D ITEM("L",SDI)
F SDI=1,2 W !,"ORDER^",$P($T(O+SDI^SCRPW22),";;",2),"^(none)^",$P($G(SDPAR("O",SDI)),U,2),"^^"
F SDI=2,1 S SDII=0 F S SDII=$O(SDPAR("PF",SDI,SDII)) Q:'SDII S SDX=SDPAR("PF",SDI,SDII) W !,"ADDL. PRINT FIELD^",$P(SDX,U,2),U,$P(SDX,U,3)
Q
;
ITEM(SDS1,SDS2) ;Print parameter item
K SD S SD(1)=$S(SDS1="P":"PERSPECTIVE",1:"LIMITATION"),SD(2)=$P(SDPAR(SDS1,SDS2),U,2),SD(3)=$P(SDPAR(SDS1,SDS2,1),U,2) I '$D(SDPAR(SDS1,SDS2,4)) D IPRT Q
S SD(5)=$P(SDPAR(SDS1,SDS2,2),U,2),SD(6)=$S($P($G(SDPAR(SDS1,SDS2,3)),U)="E":"EXCLUDE",1:"INCLUDE")
I $G(SDPAR(SDS1,SDS2,6))="D" S SDS3=0 D Q
.F S SDS3=$O(SDPAR(SDS1,SDS2,5,SDS3)) Q:'SDS3 S SD(4)=SDPAR(SDS1,SDS2,5,SDS3) D IPRT
.Q
S SDS3="" F S SDS3=$O(SDPAR(SDS1,SDS2,4,SDS3)) Q:SDS3="" S SD(4)=SDS3 D IPRT
Q
;
IPRT N SDI W ! F SDI=1:1:6 W $G(SD(SDI)) W:SDI'=6 U ;SD*5.3*232 TEJ- N SDI
Q
;
BRK(SDX) ;Print table break
D STOP^SCRPW26 Q:SDOUT
N SDY S SDY="",$P(SDY,"-",(132-$L(SDX)\2))=SDX F S SDY=SDY_"-" Q:$L(SDY)>131
Q SDY
;
EXT() ;Return external value
Q $S($G(SDPAR("P",1,6))="D":SDS2,1:SDS1)
;
RSUM ;Print report summary
W !,$$BRK("Report Summary") Q:SDOUT
W !,$P(SDPAR("P",1,1),U,2),U,"ENCOUNTERS",U,"VISITS",U,"UNIQUES"
I SDF(2) W U,"PRIOR YEAR ENCOUNTERS",U,"PRIOR YEAR VISITS",U,"PRIOR YEAR UNIQUES",U,"% CHANGE ENCOUNTERS",U,"% CHANGE VISITS",U,"% CHANGE UNIQUES" ;SD*562 correct heading to % change encounters
I '$D(^TMP("SCRPW",$J,"RPT",1)) W !,"No data found within selected parameters." Q
S SDORDV="" F S SDORDV=$O(^TMP("SCRPW",$J,"MASTER",SDORDV),$S(SDORD="ALP":1,1:-1)) Q:SDORDV=""!SDOUT D RSUM0
Q:SDOUT D RSUM1("TOT",1,1) Q
;
RSUM0 S SDS1="" F S SDS1=$O(^TMP("SCRPW",$J,"MASTER",SDORDV,SDS1)) Q:SDS1=""!SDOUT S SDS2="" F S SDS2=$O(^TMP("SCRPW",$J,"MASTER",SDORDV,SDS1,SDS2)) Q:SDS2=""!SDOUT D RSUM1("RPT",SDS1,SDS2)
Q
;
RSUM1(SDRPT,SDS1,SDS2) D STOP Q:SDOUT
K SDX S SDX=$S(SDRPT="TOT":"REPORT TOTAL",$G(SDPAR("P",1,6))="D":SDS2,1:SDS1)
S SDX(0)=+$G(^TMP("SCRPW",$J,SDRPT,1,SDS1,SDS2,"ENC")),SDX(1)=+$G(^TMP("SCRPW",$J,SDRPT,1,SDS1,SDS2,"VIS")),SDX(2)=+$G(^TMP("SCRPW",$J,SDRPT,1,SDS1,SDS2,"UNI"))
I SDF(2) S SDX(3)=+$G(^TMP("SCRPW",$J,SDRPT,2,SDS1,SDS2,"ENC")),SDX(4)=+$G(^TMP("SCRPW",$J,SDRPT,2,SDS1,SDS2,"VIS")),SDX(5)=+$G(^TMP("SCRPW",$J,SDRPT,2,SDS1,SDS2,"UNI"))
I SDF(2) F SDI=6,7,8 D CALC(SDI)
W !,SDX S SDI="" F S SDI=$O(SDX(SDI)) Q:SDI="" W U,$S(SDX(SDI)="N/A":$J(SDX(SDI),8),1:$J(SDX(SDI),8,$S(SDI<6:0,SDX(SDI)'<100000:0,SDX(SDI)'<10000:1,1:2)))
Q
;
CALC(SDI) ;Calculate % change
S SDX(SDI)=$S(SDX(SDI-3)<1:"N/A",1:SDX(SDI-6)-SDX(SDI-3)*100/SDX(SDI-3))
;
RDET Q:SDF(1)="S" S SDS1="" F S SDS1=$O(^TMP("SCRPW",$J,"RPT",1,SDS1)) Q:SDS1=""!SDOUT S SDS2="" F S SDS2=$O(^TMP("SCRPW",$J,"RPT",1,SDS1,SDS2)) Q:SDS2=""!SDOUT D RDET1
Q
;
RDET1 S SDENC=^TMP("SCRPW",$J,"RPT",1,SDS1,SDS2,"ENC"),SDVIS=^TMP("SCRPW",$J,"RPT",1,SDS1,SDS2,"VIS"),SDUNI=^TMP("SCRPW",$J,"RPT",1,SDS1,SDS2,"UNI")
D:"EB"[SDF(3) DPTL Q:SDOUT D:"DB"[SDF(3) DDXP Q
;
DSV(SDPER) ;Encrypt detail sort values
N SDX S SDX=$G(^TMP("SCRPW",$J,"DSV",$P(SDPER,U,2),$P(SDPER,U))) Q:SDX SDX
S (SDX,^TMP("SCRPW",$J,"DSV",0))=$G(^TMP("SCRPW",$J,"DSV",0))+1
S ^TMP("SCRPW",$J,"DSV",$P(SDPER,U,2),$P(SDPER,U))=SDX Q SDX
;
DPTL ;Detail patient list
N SDX1,SDDSV S SDDSV=$$DSV(SDS2_"^"_SDS1)
S SDX1=$P(SDPAR("P",1,1),U,2)_": "_$$EXT()_" - "_$S(SDF(4)="E":"Encounter",SDF(4)="V":"Visit",1:"Unique patient")_" list" W !,$$BRK(SDX1) Q:SDOUT
W !,"PATIENT",U,"SSN" I "VE"[SDF(4) W U,"DATE" I SDF(4)="E" W U,"LOCATION"
K ^TMP("SCRPW",$J,"APFM") S SDAPFM=0 D:$D(SDPAR("PF")) APFH
S SDPNAM="" F S SDPNAM=$O(^TMP("SCRPW",$J,"DET",SDDSV,SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,"DET",SDDSV,SDPNAM,DFN)) Q:'DFN!SDOUT D DPTL1
Q:'$D(^TMP("SCRPW",$J,"APFM"))
W !,$$BRK(SDX1_" (LINKED SUB-TABLE)") Q:SDOUT W !,"LINK^DATA VALUE"
S SDAPFM=0 F S SDAPFM=$O(^TMP("SCRPW",$J,"APFM",SDAPFM)) Q:'SDAPFM!SDOUT S SDX="" F S SDX=$O(^TMP("SCRPW",$J,"APFM",SDAPFM,SDX)) Q:SDX=""!SDOUT W !,SDAPFM,U,^TMP("SCRPW",$J,"APFM",SDAPFM,SDX) D STOP
Q
;
STOP S SDSTOP=SDSTOP+1 D:SDSTOP#100=0 STOP^SCRPW26 Q
;
DPTL1 I SDF(4)="U" W !,SDPNAM,U,$P($G(^DPT(DFN,0)),U,9) D APFP,STOP Q
S SDT=0 F S SDT=$O(^TMP("SCRPW",$J,"DET",SDDSV,SDPNAM,DFN,SDT)) Q:'SDT!SDOUT D DPTL2
Q
;
DPTL2 I SDF(4)="V" W !,SDPNAM,U,$P($G(^DPT(DFN,0)),U,9) S Y=SDT X ^DD("DD") W U,Y D APFP,STOP Q
S SDDT=0 F S SDDT=$O(^TMP("SCRPW",$J,"DET",SDDSV,SDPNAM,DFN,SDT,SDDT)) Q:'SDDT!SDOUT S SDOE=0 F S SDOE=$O(^TMP("SCRPW",$J,"DET",SDDSV,SDPNAM,DFN,SDT,SDDT,SDOE)) Q:'SDOE!SDOUT D DPTL3
Q
;
DPTL3 D STOP Q:SDOUT S SDCL=^TMP("SCRPW",$J,"DET",SDDSV,SDPNAM,DFN,SDT,SDDT,SDOE),SDCL=$P($G(^SC(SDCL,0)),U),Y=SDDT X ^DD("DD")
W !,SDPNAM,U,$P($G(^DPT(DFN,0)),U,9),U,Y,U,SDCL D APFP Q
;
DDXP ;Detail dx/procedure lists
W !,$$BRK($P(SDPAR("P",1,1),U,2)_": "_$$EXT()_" - Diagnosis ranking") Q:SDOUT
W !,"DIAGNOSIS",U,"PRIMARY",U,"SECONDARY",U,"TOTAL"
I '$D(^TMP("SCRPW",$J,"RPTTDX",1,SDS1,SDS2)) W !,"No diagnoses found for this detail item." G DAPP
K SDTCT S SDQT="",SDCT=0 F S SDQT=$O(^TMP("SCRPW",$J,"RPTTDX",1,SDS1,SDS2,SDQT),-1) Q:SDQT=""!(SDCT>SDF(5))!SDOUT S SDS3="" F S SDS3=$O(^TMP("SCRPW",$J,"RPTTDX",1,SDS1,SDS2,SDQT,SDS3)) Q:SDS3=""!(SDCT>SDF(5))!SDOUT D DDXP1
Q:SDOUT W !,"TOTAL",U,$J(SDTCT(1),10),U,$J(SDTCT(2),10),U,$J(SDTCT(3),10)
;
DAPP W !,$$BRK($P(SDPAR("P",1,1),U,2)_": "_$$EXT()_" - Ambulatory procedure ranking") Q:SDOUT W !,"PROCEDURES",U,"TOTAL"
I '$D(^TMP("SCRPW",$J,"RPTTAP",1,SDS1,SDS2)) W !,"No procedures found for this detail item." Q
K SDTCT S SDQT="",SDCT=0 F S SDQT=$O(^TMP("SCRPW",$J,"RPTTAP",1,SDS1,SDS2,SDQT),-1) Q:SDQT=""!(SDCT>SDF(5))!SDOUT S SDS3="" F S SDS3=$O(^TMP("SCRPW",$J,"RPTTAP",1,SDS1,SDS2,SDQT,SDS3)) Q:SDS3=""!(SDCT>SDF(5))!SDOUT D DAPP1
Q:SDOUT W !,"TOTAL",U,$J(SDTCT(1),10)
Q
;
DDXP1 F SDI=1,2,3 S SDICT(SDI)=+$P(^TMP("SCRPW",$J,"RPTDX",1,SDS1,SDS2,SDS3),U,SDI),SDTCT(SDI)=$G(SDTCT(SDI))+SDICT(SDI)
W !,SDS3,U,$J(SDICT(1),10),U,$J(SDICT(2),10),U,$J(SDICT(3),10) S SDCT=SDCT+1 D STOP Q
;
DAPP1 S SDICT(1)=^TMP("SCRPW",$J,"RPTAP",1,SDS1,SDS2,SDS3),SDTCT(1)=$G(SDTCT(1))+SDICT(1)
W !,SDS3,U,$J(SDICT(1),10) S SDCT=SDCT+1 D STOP Q
;
APFH ;Addl. print fields header
N S1,S2,SDX
F S1=2,1 S S2=0 F S S2=$O(SDPAR("PF",S1,S2)) Q:'S2 S SDX=SDPAR("PF",S1,S2) W U,$P(^TMP("SCRPW",$J,"ACT",$P(SDX,U)),T) W:$P(^TMP("SCRPW",$J,"ACT",$P(SDX,U)),T,12) " (LINK)"
Q
;
APFP ;Addl. print fields print
N S1,S2,SDX,SDACT,SDY,SDOE0
F S1=2,1 S S2=0 F S S2=$O(SDPAR("PF",S1,S2)) Q:'S2 S SDY=SDPAR("PF",S1,S2),SDACT=^TMP("SCRPW",$J,"ACT",$P(SDY,U)),SDOE0=$$OE0() K SDX X $P(SDACT,T,7) W U,$$APF()
Q
;
APF() N SDZ S (SDZ,SDX)="" S SDX=$O(SDX(SDX)) Q:'$P(SDACT,T,12) $P(SDX(SDX),U,2)
S SDAPFM=SDAPFM+1,SDX="" F S SDX=$O(SDX(SDX)) Q:SDX="" S ^TMP("SCRPW",$J,"APFM",SDAPFM,SDX)=$P(SDX(SDX),U,2)
Q SDAPFM
;
OE0() ;Get encounter node
Q:"UV"[SDF(4) U_DFN_U
Q $$GETOE^SDOE(SDOE)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW28 7614 printed Dec 13, 2024@02:43:32 Page 2
SCRPW28 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 12/5/00 4:44pm
+1 ;;5.3;Scheduling;**144,232,562**;AUG 13, 1993;Build 7
PDF ;Print delimited format
+1 SET (SDOUT,SDSTOP)=0
DO RPAR
DO RSUM
DO RDET
GOTO EXIT^SCRPW27
+2 ;
RPAR WRITE !,$$BRK("Report Parameters")
if SDOUT
QUIT
+1 WRITE !,"TYPE^CATEGORY^SUB-CATEGORY^VALUE^METHOD^INCLUDE/EXCLUDE"
+2 SET SDI=0
FOR
SET SDI=$ORDER(SDPAR("F",SDI))
if 'SDI
QUIT
WRITE !,"FORMAT^",$PIECE($TEXT(F+SDI^SCRPW22),";;",2),"^(none)^",$PIECE(SDPAR("F",SDI),U,2),"^^"
+3 DO ITEM("P",1)
FOR SDI=1,2
WRITE !,"LIMITATION^",$PIECE($TEXT(L+SDI^SCRPW22),";;",2),"^(none)^",$PIECE(SDPAR("L",SDI),U,2),"^^"
+4 SET SDI=2
FOR
SET SDI=$ORDER(SDPAR("L",SDI))
if 'SDI
QUIT
DO ITEM("L",SDI)
+5 FOR SDI=1,2
WRITE !,"ORDER^",$PIECE($TEXT(O+SDI^SCRPW22),";;",2),"^(none)^",$PIECE($GET(SDPAR("O",SDI)),U,2),"^^"
+6 FOR SDI=2,1
SET SDII=0
FOR
SET SDII=$ORDER(SDPAR("PF",SDI,SDII))
if 'SDII
QUIT
SET SDX=SDPAR("PF",SDI,SDII)
WRITE !,"ADDL. PRINT FIELD^",$PIECE(SDX,U,2),U,$PIECE(SDX,U,3)
+7 QUIT
+8 ;
ITEM(SDS1,SDS2) ;Print parameter item
+1 KILL SD
SET SD(1)=$SELECT(SDS1="P":"PERSPECTIVE",1:"LIMITATION")
SET SD(2)=$PIECE(SDPAR(SDS1,SDS2),U,2)
SET SD(3)=$PIECE(SDPAR(SDS1,SDS2,1),U,2)
IF '$DATA(SDPAR(SDS1,SDS2,4))
DO IPRT
QUIT
+2 SET SD(5)=$PIECE(SDPAR(SDS1,SDS2,2),U,2)
SET SD(6)=$SELECT($PIECE($GET(SDPAR(SDS1,SDS2,3)),U)="E":"EXCLUDE",1:"INCLUDE")
+3 IF $GET(SDPAR(SDS1,SDS2,6))="D"
SET SDS3=0
Begin DoDot:1
+4 FOR
SET SDS3=$ORDER(SDPAR(SDS1,SDS2,5,SDS3))
if 'SDS3
QUIT
SET SD(4)=SDPAR(SDS1,SDS2,5,SDS3)
DO IPRT
+5 QUIT
End DoDot:1
QUIT
+6 SET SDS3=""
FOR
SET SDS3=$ORDER(SDPAR(SDS1,SDS2,4,SDS3))
if SDS3=""
QUIT
SET SD(4)=SDS3
DO IPRT
+7 QUIT
+8 ;
IPRT ;SD*5.3*232 TEJ- N SDI
NEW SDI
WRITE !
FOR SDI=1:1:6
WRITE $GET(SD(SDI))
if SDI'=6
WRITE U
+1 QUIT
+2 ;
BRK(SDX) ;Print table break
+1 DO STOP^SCRPW26
if SDOUT
QUIT
+2 NEW SDY
SET SDY=""
SET $PIECE(SDY,"-",(132-$LENGTH(SDX)\2))=SDX
FOR
SET SDY=SDY_"-"
if $LENGTH(SDY)>131
QUIT
+3 QUIT SDY
+4 ;
EXT() ;Return external value
+1 QUIT $SELECT($GET(SDPAR("P",1,6))="D":SDS2,1:SDS1)
+2 ;
RSUM ;Print report summary
+1 WRITE !,$$BRK("Report Summary")
if SDOUT
QUIT
+2 WRITE !,$PIECE(SDPAR("P",1,1),U,2),U,"ENCOUNTERS",U,"VISITS",U,"UNIQUES"
+3 ;SD*562 correct heading to % change encounters
IF SDF(2)
WRITE U,"PRIOR YEAR ENCOUNTERS",U,"PRIOR YEAR VISITS",U,"PRIOR YEAR UNIQUES",U,"% CHANGE ENCOUNTERS",U,"% CHANGE VISITS",U,"% CHANGE UNIQUES"
+4 IF '$DATA(^TMP("SCRPW",$JOB,"RPT",1))
WRITE !,"No data found within selected parameters."
QUIT
+5 SET SDORDV=""
FOR
SET SDORDV=$ORDER(^TMP("SCRPW",$JOB,"MASTER",SDORDV),$SELECT(SDORD="ALP":1,1:-1))
if SDORDV=""!SDOUT
QUIT
DO RSUM0
+6 if SDOUT
QUIT
DO RSUM1("TOT",1,1)
QUIT
+7 ;
RSUM0 SET SDS1=""
FOR
SET SDS1=$ORDER(^TMP("SCRPW",$JOB,"MASTER",SDORDV,SDS1))
if SDS1=""!SDOUT
QUIT
SET SDS2=""
FOR
SET SDS2=$ORDER(^TMP("SCRPW",$JOB,"MASTER",SDORDV,SDS1,SDS2))
if SDS2=""!SDOUT
QUIT
DO RSUM1("RPT",SDS1,SDS2)
+1 QUIT
+2 ;
RSUM1(SDRPT,SDS1,SDS2) DO STOP
if SDOUT
QUIT
+1 KILL SDX
SET SDX=$SELECT(SDRPT="TOT":"REPORT TOTAL",$GET(SDPAR("P",1,6))="D":SDS2,1:SDS1)
+2 SET SDX(0)=+$GET(^TMP("SCRPW",$JOB,SDRPT,1,SDS1,SDS2,"ENC"))
SET SDX(1)=+$GET(^TMP("SCRPW",$JOB,SDRPT,1,SDS1,SDS2,"VIS"))
SET SDX(2)=+$GET(^TMP("SCRPW",$JOB,SDRPT,1,SDS1,SDS2,"UNI"))
+3 IF SDF(2)
SET SDX(3)=+$GET(^TMP("SCRPW",$JOB,SDRPT,2,SDS1,SDS2,"ENC"))
SET SDX(4)=+$GET(^TMP("SCRPW",$JOB,SDRPT,2,SDS1,SDS2,"VIS"))
SET SDX(5)=+$GET(^TMP("SCRPW",$JOB,SDRPT,2,SDS1,SDS2,"UNI"))
+4 IF SDF(2)
FOR SDI=6,7,8
DO CALC(SDI)
+5 WRITE !,SDX
SET SDI=""
FOR
SET SDI=$ORDER(SDX(SDI))
if SDI=""
QUIT
WRITE U,$SELECT(SDX(SDI)="N/A":$JUSTIFY(SDX(SDI),8),1:$JUSTIFY(SDX(SDI),8,$SELECT(SDI<6:0,SDX(SDI)'<100000:0,SDX(SDI)'<10000:1,1:2)))
+6 QUIT
+7 ;
CALC(SDI) ;Calculate % change
+1 SET SDX(SDI)=$SELECT(SDX(SDI-3)<1:"N/A",1:SDX(SDI-6)-SDX(SDI-3)*100/SDX(SDI-3))
+2 ;
RDET if SDF(1)="S"
QUIT
SET SDS1=""
FOR
SET SDS1=$ORDER(^TMP("SCRPW",$JOB,"RPT",1,SDS1))
if SDS1=""!SDOUT
QUIT
SET SDS2=""
FOR
SET SDS2=$ORDER(^TMP("SCRPW",$JOB,"RPT",1,SDS1,SDS2))
if SDS2=""!SDOUT
QUIT
DO RDET1
+1 QUIT
+2 ;
RDET1 SET SDENC=^TMP("SCRPW",$JOB,"RPT",1,SDS1,SDS2,"ENC")
SET SDVIS=^TMP("SCRPW",$JOB,"RPT",1,SDS1,SDS2,"VIS")
SET SDUNI=^TMP("SCRPW",$JOB,"RPT",1,SDS1,SDS2,"UNI")
+1 if "EB"[SDF(3)
DO DPTL
if SDOUT
QUIT
if "DB"[SDF(3)
DO DDXP
QUIT
+2 ;
DSV(SDPER) ;Encrypt detail sort values
+1 NEW SDX
SET SDX=$GET(^TMP("SCRPW",$JOB,"DSV",$PIECE(SDPER,U,2),$PIECE(SDPER,U)))
if SDX
QUIT SDX
+2 SET (SDX,^TMP("SCRPW",$JOB,"DSV",0))=$GET(^TMP("SCRPW",$JOB,"DSV",0))+1
+3 SET ^TMP("SCRPW",$JOB,"DSV",$PIECE(SDPER,U,2),$PIECE(SDPER,U))=SDX
QUIT SDX
+4 ;
DPTL ;Detail patient list
+1 NEW SDX1,SDDSV
SET SDDSV=$$DSV(SDS2_"^"_SDS1)
+2 SET SDX1=$PIECE(SDPAR("P",1,1),U,2)_": "_$$EXT()_" - "_$SELECT(SDF(4)="E":"Encounter",SDF(4)="V":"Visit",1:"Unique patient")_" list"
WRITE !,$$BRK(SDX1)
if SDOUT
QUIT
+3 WRITE !,"PATIENT",U,"SSN"
IF "VE"[SDF(4)
WRITE U,"DATE"
IF SDF(4)="E"
WRITE U,"LOCATION"
+4 KILL ^TMP("SCRPW",$JOB,"APFM")
SET SDAPFM=0
if $DATA(SDPAR("PF"))
DO APFH
+5 SET SDPNAM=""
FOR
SET SDPNAM=$ORDER(^TMP("SCRPW",$JOB,"DET",SDDSV,SDPNAM))
if SDPNAM=""!SDOUT
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,"DET",SDDSV,SDPNAM,DFN))
if 'DFN!SDOUT
QUIT
DO DPTL1
+6 if '$DATA(^TMP("SCRPW",$JOB,"APFM"))
QUIT
+7 WRITE !,$$BRK(SDX1_" (LINKED SUB-TABLE)")
if SDOUT
QUIT
WRITE !,"LINK^DATA VALUE"
+8 SET SDAPFM=0
FOR
SET SDAPFM=$ORDER(^TMP("SCRPW",$JOB,"APFM",SDAPFM))
if 'SDAPFM!SDOUT
QUIT
SET SDX=""
FOR
SET SDX=$ORDER(^TMP("SCRPW",$JOB,"APFM",SDAPFM,SDX))
if SDX=""!SDOUT
QUIT
WRITE !,SDAPFM,U,^TMP("SCRPW",$JOB,"APFM",SDAPFM,SDX)
DO STOP
+9 QUIT
+10 ;
STOP SET SDSTOP=SDSTOP+1
if SDSTOP#100=0
DO STOP^SCRPW26
QUIT
+1 ;
DPTL1 IF SDF(4)="U"
WRITE !,SDPNAM,U,$PIECE($GET(^DPT(DFN,0)),U,9)
DO APFP
DO STOP
QUIT
+1 SET SDT=0
FOR
SET SDT=$ORDER(^TMP("SCRPW",$JOB,"DET",SDDSV,SDPNAM,DFN,SDT))
if 'SDT!SDOUT
QUIT
DO DPTL2
+2 QUIT
+3 ;
DPTL2 IF SDF(4)="V"
WRITE !,SDPNAM,U,$PIECE($GET(^DPT(DFN,0)),U,9)
SET Y=SDT
XECUTE ^DD("DD")
WRITE U,Y
DO APFP
DO STOP
QUIT
+1 SET SDDT=0
FOR
SET SDDT=$ORDER(^TMP("SCRPW",$JOB,"DET",SDDSV,SDPNAM,DFN,SDT,SDDT))
if 'SDDT!SDOUT
QUIT
SET SDOE=0
FOR
SET SDOE=$ORDER(^TMP("SCRPW",$JOB,"DET",SDDSV,SDPNAM,DFN,SDT,SDDT,SDOE))
if 'SDOE!SDOUT
QUIT
DO DPTL3
+2 QUIT
+3 ;
DPTL3 DO STOP
if SDOUT
QUIT
SET SDCL=^TMP("SCRPW",$JOB,"DET",SDDSV,SDPNAM,DFN,SDT,SDDT,SDOE)
SET SDCL=$PIECE($GET(^SC(SDCL,0)),U)
SET Y=SDDT
XECUTE ^DD("DD")
+1 WRITE !,SDPNAM,U,$PIECE($GET(^DPT(DFN,0)),U,9),U,Y,U,SDCL
DO APFP
QUIT
+2 ;
DDXP ;Detail dx/procedure lists
+1 WRITE !,$$BRK($PIECE(SDPAR("P",1,1),U,2)_": "_$$EXT()_" - Diagnosis ranking")
if SDOUT
QUIT
+2 WRITE !,"DIAGNOSIS",U,"PRIMARY",U,"SECONDARY",U,"TOTAL"
+3 IF '$DATA(^TMP("SCRPW",$JOB,"RPTTDX",1,SDS1,SDS2))
WRITE !,"No diagnoses found for this detail item."
GOTO DAPP
+4 KILL SDTCT
SET SDQT=""
SET SDCT=0
FOR
SET SDQT=$ORDER(^TMP("SCRPW",$JOB,"RPTTDX",1,SDS1,SDS2,SDQT),-1)
if SDQT=""!(SDCT>SDF(5))!SDOUT
QUIT
SET SDS3=""
FOR
SET SDS3=$ORDER(^TMP("SCRPW",$JOB,"RPTTDX",1,SDS1,SDS2,SDQT,SDS3))
if SDS3=""!(SDCT>SDF(5))!SDOUT
QUIT
DO DDXP1
+5 if SDOUT
QUIT
WRITE !,"TOTAL",U,$JUSTIFY(SDTCT(1),10),U,$JUSTIFY(SDTCT(2),10),U,$JUSTIFY(SDTCT(3),10)
+6 ;
DAPP WRITE !,$$BRK($PIECE(SDPAR("P",1,1),U,2)_": "_$$EXT()_" - Ambulatory procedure ranking")
if SDOUT
QUIT
WRITE !,"PROCEDURES",U,"TOTAL"
+1 IF '$DATA(^TMP("SCRPW",$JOB,"RPTTAP",1,SDS1,SDS2))
WRITE !,"No procedures found for this detail item."
QUIT
+2 KILL SDTCT
SET SDQT=""
SET SDCT=0
FOR
SET SDQT=$ORDER(^TMP("SCRPW",$JOB,"RPTTAP",1,SDS1,SDS2,SDQT),-1)
if SDQT=""!(SDCT>SDF(5))!SDOUT
QUIT
SET SDS3=""
FOR
SET SDS3=$ORDER(^TMP("SCRPW",$JOB,"RPTTAP",1,SDS1,SDS2,SDQT,SDS3))
if SDS3=""!(SDCT>SDF(5))!SDOUT
QUIT
DO DAPP1
+3 if SDOUT
QUIT
WRITE !,"TOTAL",U,$JUSTIFY(SDTCT(1),10)
+4 QUIT
+5 ;
DDXP1 FOR SDI=1,2,3
SET SDICT(SDI)=+$PIECE(^TMP("SCRPW",$JOB,"RPTDX",1,SDS1,SDS2,SDS3),U,SDI)
SET SDTCT(SDI)=$GET(SDTCT(SDI))+SDICT(SDI)
+1 WRITE !,SDS3,U,$JUSTIFY(SDICT(1),10),U,$JUSTIFY(SDICT(2),10),U,$JUSTIFY(SDICT(3),10)
SET SDCT=SDCT+1
DO STOP
QUIT
+2 ;
DAPP1 SET SDICT(1)=^TMP("SCRPW",$JOB,"RPTAP",1,SDS1,SDS2,SDS3)
SET SDTCT(1)=$GET(SDTCT(1))+SDICT(1)
+1 WRITE !,SDS3,U,$JUSTIFY(SDICT(1),10)
SET SDCT=SDCT+1
DO STOP
QUIT
+2 ;
APFH ;Addl. print fields header
+1 NEW S1,S2,SDX
+2 FOR S1=2,1
SET S2=0
FOR
SET S2=$ORDER(SDPAR("PF",S1,S2))
if 'S2
QUIT
SET SDX=SDPAR("PF",S1,S2)
WRITE U,$PIECE(^TMP("SCRPW",$JOB,"ACT",$PIECE(SDX,U)),T)
if $PIECE(^TMP("SCRPW",$JOB,"ACT",$PIECE(SDX,U)),T,12)
WRITE " (LINK)"
+3 QUIT
+4 ;
APFP ;Addl. print fields print
+1 NEW S1,S2,SDX,SDACT,SDY,SDOE0
+2 FOR S1=2,1
SET S2=0
FOR
SET S2=$ORDER(SDPAR("PF",S1,S2))
if 'S2
QUIT
SET SDY=SDPAR("PF",S1,S2)
SET SDACT=^TMP("SCRPW",$JOB,"ACT",$PIECE(SDY,U))
SET SDOE0=$$OE0()
KILL SDX
XECUTE $PIECE(SDACT,T,7)
WRITE U,$$APF()
+3 QUIT
+4 ;
APF() NEW SDZ
SET (SDZ,SDX)=""
SET SDX=$ORDER(SDX(SDX))
if '$PIECE(SDACT,T,12)
QUIT $PIECE(SDX(SDX),U,2)
+1 SET SDAPFM=SDAPFM+1
SET SDX=""
FOR
SET SDX=$ORDER(SDX(SDX))
if SDX=""
QUIT
SET ^TMP("SCRPW",$JOB,"APFM",SDAPFM,SDX)=$PIECE(SDX(SDX),U,2)
+2 QUIT SDAPFM
+3 ;
OE0() ;Get encounter node
+1 if "UV"[SDF(4)
QUIT U_DFN_U
+2 QUIT $$GETOE^SDOE(SDOE)
