- 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 Mar 13, 2025@21:48:27 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)
