SCRPW47 ;RENO/KEITH/MLR - Outpatient Diagnosis/Procedure Code Search (cont.) ; 9/29/00 12:34pm
;;5.3;Scheduling;**144,180,199,1015**;AUG 13, 1993;Build 21
;;07/22/99 ACS - Added CPT modifiers to the report
; *199*
; - Summary section correction (multiple divisions)
; - Addition of Secondary Division subscript variable: DIV0
; - Displaying only divisions with matching criterial in subheader
;
N SDIV S SDIV=""
F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:SDIV=""!SDOUT D
. S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,1,DFN)) Q:'DFN!SDOUT D
.. S (DIV1,DIV0)=0 F S DIV0=$O(^TMP("SCRPW",$J,SDIV,1,DFN,DIV0)) Q:'DIV0 D
...; Screening "DR" or "PR" levels (SDZ) prior to setting print level
...; Note: Patient must have valid Diagnosis or Procedure to print
... Q:$G(^TMP("SCRPW",$J,0,1,DFN,DIV0,SDZ))=""
... S SDSTOP=SDSTOP+1 D:SDSTOP#1000=0 STOP Q:SDOUT
... S SDPT0=$G(^DPT(DFN,0)),SDPTNA=$P(SDPT0,U)
... S:$L(SDPTNA) ^TMP("SCRPW",$J,SDIV,2,SDPTNA,DFN,DIV0)=$P(SDPT0,U,9)
;
G:SDOUT EXIT
D:$E(IOST)="C" DISP0^SCRPW23
K SDTIT
S SDTIT(1)="<*> OUTPATIENT DIAGNOSIS/PROCEDURE CODE SEARCH <*>"
D HINI^SCRPW46,BLD^SCRPW21
S SDTIT(2)="Report Parameters Selected"
D HDR G:SDOUT EXIT D PD1(0) G:SDOUT EXIT
;if no data in file, exit from program
I '$D(^TMP("SCRPW",$J,0,1)) D G EXIT
. K SDTIT(2) D HDR G:SDOUT EXIT
. S SDX="No activity found within selected report parameters!"
. W !!?(IOM-$L(SDX)\2),SDX
. Q
;
I $P(SDDIV,U,2)="SELECTED DIVISIONS" D
. S SDI=0 F S SDI=$O(SDDIV(SDI)) Q:'SDI S SDIVL(SDDIV(SDI))=SDI
;
I $P(SDDIV,U,2)="ALL DIVISIONS" D
. S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,0,SDI)) Q:'SDI D
.. S SDX=$P($G(^DG(40.8,SDI,0)),U)
.. S:'$L(SDX) SDX="***UNKNOWN***"
.. S SDIVL(SDX)=SDI
;
S:'$D(SDIVL) SDIVL($P(SDDIV,U,2))=$P(SDDIV,U)
D:$E(IOST)="C" DISP0^SCRPW23 S SDCOL=$S(IOM=80:0,1:26)
S SDIVN=""
F S SDIVN=$O(SDIVL(SDIVN)) Q:SDIVN=""!SDOUT D DPRT(SDIVL(SDIVN))
G:SDOUT EXIT S SDMD=0,SDMD=$O(^TMP("SCRPW",$J,SDMD)),SDMD=$O(^TMP("SCRPW",$J,SDMD)) D:SDMD DPRT(0)
I $E(IOST)="C",'SDOUT W ! N DIR S DIR(0)="E" D ^DIR
;
EXIT D END^SCRPW50
K %,%H,%I,%DT,DFN,DIC,DIR,DTOUT,DUOUT,S1,S2,SD,SDACT,SDAPF,SDBAD,SDC
K SDC1,SDCL,SDCOL,SDCPT,SDCRI,SDCT,SDD,SDDIV,SDDX,SDEXE,SDF,SDFF
K SDI,SDI2,SDII,SDIII,SDITX,SDIV,SDIVL,SDIVN,SDIXE,SDL,SDL1,SDLAB
K SDLAST,SDLF,SDLINE,SDLIST,SDLOC,SDLTH,SDMD,SDNUL,SDOE,SDOE0,SDOTX
K SDOUT,SDOXE,SDP,SDPAGE,SDPAR,SDPDIV,SDPNAM,SDPNOW,SDPT0,SDPTNA,SDR
K SDR1,SDR2,SDSEL,SDSSN,SDSTOP,SDSTR,SDT,SDTIT,SDTX,SDTXB,SDTY,SDUI
K SDUII,SDUIII,SDUIV,SDUJC,SDRESP,SDS1,SDS2,SDV,SDVAL,SDVAR,SDX,SDX2
K SDFMT,SDY,SDZ,X,X1,X2,X3,X4,Y,Z
Q ;EXIT
;
HDR D HDR^SCRPW46 Q
;
HD1 ;Report subheader
Q:SDOUT
W !?(SDCOL),"Patient/Division:",?(SDCOL+26),"SSN:"
W ?(SDCOL+38),$S('$D(SD("LIST","P")):"Diagnoses:",'$D(SD("LIST","D")):"Procedures/Modifiers:",1:"Diagnoses/Procedures:")
W !?(SDCOL),$E(SDLINE,1,24),?(SDCOL+26),$E(SDLINE,1,10)
W ?(SDCOL+38),$E(SDLINE,1,42)
Q ;HD1
;
STOP ;Check for stop task request
S:$D(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
;
DPRT(SDV) ;Print report for a division
;Required input: SDV=division ifn or '0' for summary
S SDIV=SDV ;copying division #
D DHDR^SCRPW46(SDV,2,.SDTIT) S SDPAGE=1 D HDR Q:SDOUT
I '$D(^TMP("SCRPW",$J,SDV,2)) D
. S SDX="No activity found within selected report parameters for this division!"
. W !!?(IOM-$L(SDX)\2),SDX Q
D HD1 S (SDCT,SDDCT,DIVB)=0,(SDPNAM,SDPNAM2)="",SDF=$P(SDFMT,U)
F S SDPNAM=$O(^TMP("SCRPW",$J,SDV,2,SDPNAM)) Q:SDPNAM=""!SDOUT D
. S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDV,2,SDPNAM,DFN)) Q:'DFN!SDOUT D
.. S SDCT=SDCT+1,DIV0=0
.. F S DIV0=$O(^TMP("SCRPW",$J,SDV,2,SDPNAM,DFN,DIV0)) Q:DIV0="" D
... S SDDCT=SDDCT+1,SDSSN=^TMP("SCRPW",$J,SDV,2,SDPNAM,DFN,DIV0)
... S SDPNAM2=SDPNAM_" "_DIV0
... D DPRT1 W !
W !?(SDCOL),$E(SDLINE,1,80)
W !?(SDCOL),"TOTAL PATIENTS IDENTIFIED: ",SDCT
I SDV=0 W !?(SDCOL),"MULTI-DIVISION PATIENTS: ",SDDCT-SDCT
Q
;
DPRT1 ;Prints name & ss# of line detail
D:$Y>(IOSL-6) HDR,HD1 Q:SDOUT
W !?(SDCOL),$E(SDPNAM2,1,24)
W ?(SDCOL+26),SDSSN
S SDLF=0
;
D ;Calling print format modules
. D PATIENT
. I SDF="V" D VISIT Q
. I SDF="E" D ENCNTR Q
. Q
Q ;DPRT1
;
PATIENT ;Prints Patient Diagnosis/Procedures for all Types of Detail
F SDI="DR","PR" I $D(^TMP("SCRPW",$J,0,1,DFN,DIV0,SDI)) D Q:SDOUT
. S SDII="" F S SDII=$O(^TMP("SCRPW",$J,0,1,DFN,DIV0,SDI,SDII)) Q:SDII=""!SDOUT D
.. D:$Y>(IOSL-4) HDR,HD1 Q:SDOUT
.. D
... W:SDLF ! Q
... I DIV1'=DIV0 S DIV1=DIV0 W ! Q
... Q
.. W ?(SDCOL+38),$E($S(SDI="DR":"Dx: ",1:"Proc.: ")_SDII,1,42) S SDLF=1
..; print mod and desc for current CPT (SDII)
..; SDII2 = modifier and description
.. I $D(^TMP("SCRPW",$J,0,1,DFN,DIV0,SDI,SDII)) D
... N SDII2 S SDII2=""
... F S SDII2=$O(^TMP("SCRPW",$J,0,1,DFN,DIV0,SDI,SDII,SDII2)) Q:'SDII2 D
.... D:$Y>(IOSL-4) HDR,HD1 Q:SDOUT
.... W !,?(SDCOL+47),"-",$E(SDII2,1,32)
.. Q
. Q
S SDI=0 F S SDI=$O(SDAPF(2,SDI)) Q:'SDI!SDOUT S SDOE0=U_DFN_U,SDY=SDAPF(2,SDI) D APF(SDY,SDOE0,5)
;
Q ;PATIENT
;
VISIT ;Printing Type of Detail: Visits
S SDT=0
F S SDT=$O(^TMP("SCRPW",$J,0,1,DFN,DIV0,"ACT",SDT)) Q:'SDT!SDOUT D
. D:$Y>(IOSL-4) HDR,HD1 Q:SDOUT
. S Y=SDT X ^DD("DD") W !?(SDCOL+10),"Visit: ",Y Q
;
Q ;VISIT
;
ENCNTR ;Printing Type of Detail: ENCOUNTER
S SDT=0
F S SDT=$O(^TMP("SCRPW",$J,0,1,DFN,DIV0,"ACT",SDT)) Q:'SDT!SDOUT D
. S SDOE=0 F S SDOE=$O(^TMP("SCRPW",$J,0,1,DFN,DIV0,"ACT",SDT,SDOE)) Q:'SDOE!SDOUT D
.. D:$Y>(IOSL-4) HDR,HD1 Q:SDOUT
.. S SDOE0=^TMP("SCRPW",$J,0,1,DFN,DIV0,"ACT",SDT,SDOE)
.. S SDLOC=$P($G(^SC(+$P(SDOE0,U,4),0)),U)
.. S Y=SDT X ^DD("DD") W !?(SDCOL+10),"Encounter: ",$P(Y,":",1,2)
.. W ?(SDCOL+40),SDLOC
.. S SDI=0 F S SDI=$O(SDAPF(1,SDI)) Q:'SDI!SDOUT S SDY=SDAPF(1,SDI) D APF(SDY,SDOE0,$S($D(SDAPF(2)):15,1:25))
.. Q
Q ;ENCNTR
;
APF(SDY,SDOE0,SDC) ;Print additional print fields
;Required input: SDY=action acronym^major category^minor category
;Required input: SDOE0=zeroeth node of OUTPATIENT ENCOUNTER record
;Required input: SDC=column to begin output
N SDACT,SDX,SDI
D:$Y>(IOSL-4) HDR,HD1 Q:SDOUT W !?(SDCOL+SDC),$P(SDY,U,3),":"
S SDACT=^TMP("SCRPW",$J,"ACT",$P(SDY,U)),SDLF=0,SDC1=SDC+2+$L($P(SDY,U,3))
K SDX X $P(SDACT,"~",7) S SDX="" F S SDX=$O(SDX(SDX)) Q:SDX=""!SDOUT D
.D:$Y>(IOSL-3) HDR,HD1 Q:SDOUT W:SDLF ! W ?(SDCOL+SDC1),$E($P(SDX(SDX),U,2),1,(80-SDC1)) S SDLF=1
.Q
Q
;
PD1(SDI) ;Print parameters
;Required input: SDI=0 for all division selections or division ifn
N SDLF,C S C=(IOM-80\2),SDLF=0 I SDI D PDP("Report for",SDDIV(SDI),1) Q:SDOUT
I 'SDI D PDP("Report for",SDDIV,2) Q:SDOUT D
.F S SDI=$O(SDDIV(SDI)) Q:'SDI!SDOUT D PDP("Division",SDDIV(SDI),1)
Q:SDOUT D PDP("Beginning date",SD("PBDT"),1,0,1) Q:SDOUT D PDP("Ending date",SD("PEDT"),1) Q:SDOUT
S SDI="" F S SDI=$O(SDPAR(SDI)) Q:SDI=""!SDOUT D
.D PDP("Search element '"_SDI_"'",SDPAR(SDI),2,0,1) Q:SDOUT S SDTY=$P(SDPAR(SDI),U)
.I SDTY["L" S SDLAB=$S(SDTY["D":"Diagnosis",1:"Procedure") S SDII=0 F S SDII=$O(SDPAR(SDI,SDII)) Q:'SDII D PDP(SDLAB,SDPAR(SDI,SDII),1) Q:SDOUT
.I SDTY["R" S SDVAL=$O(SDPAR(SDI,"")) D PDP("From",SDVAL,1) Q:SDOUT S SDVAL=$O(SDPAR(SDI,SDVAL)) D PDP("To",SDVAL,1)
.Q
S SDI="" F S SDI=$O(SDCRI(SDI)) Q:SDI=""!SDOUT D
.D PDP("Combine logic",SDI,1,0,1) Q:SDOUT M SDITX=SDCRI(SDI) D WRAP^SCRPW45(.SDITX,.SDOTX,,,60,"") S SDII="" F S SDII=$O(SDOTX(SDII)) Q:SDII=""!SDOUT D
..S SDLF=SDLF+1 I $E(IOST)="C",SDLF#18=0 D WAIT Q:SDOUT
..I $Y>(IOSL-3),$E(IOST)="P" D HDR Q:SDOUT
..S SDX=SDOTX(SDII) W !?(IOM-$L(SDX)\2),SDX
..Q
.Q
D PDP("Type of detail",SDFMT,2,0,1) Q:SDOUT
S SDIII=0 F SDI=2,1 S SDII=0 F S SDII=$O(SDAPF(SDI,SDII)) Q:'SDII!SDOUT D
.D PDP("Additional print fields",SDAPF(SDI,SDII),3,SDIII,'SDIII) S SDIII=1
D:$E(IOST)="C" WAIT Q
;
PDP(SDT,SDX,SDP,SDL,SDL1) ;Print parameter display line
;Required input: SDT=parameter title
;Required input: SDX=parameter value
;Required input: SDP=$P of SDX to print
;Optional input: SDL=1 to suppress title and do line feed
;Optional input: SDL1=1 to do additional line feed
S SDLF=SDLF+1 I $E(IOST)="C",SDLF#18=0 D WAIT Q:SDOUT
I $Y>(IOSL-3),$E(IOST)="P" D HDR Q:SDOUT
I $G(SDL1) W ! S SDLF=SDLF+1 I $E(IOST)="C",SDLF#18=0 D WAIT Q:SDOUT
W ! W:'$G(SDL) $J(SDT,(IOM-6\2)),":" W ?(IOM\2-1),$P(SDX,U,SDP) Q
;
WAIT ;Do CRT pause
N DIR W ! S DIR(0)="E" D ^DIR S SDOUT=Y'=1 W ! Q
SCRPW47 ;RENO/KEITH/MLR - Outpatient Diagnosis/Procedure Code Search (cont.) ; 9/29/00 12:34pm
+1 ;;5.3;Scheduling;**144,180,199,1015**;AUG 13, 1993;Build 21
+2 ;;07/22/99 ACS - Added CPT modifiers to the report
+3 ; *199*
+4 ; - Summary section correction (multiple divisions)
+5 ; - Addition of Secondary Division subscript variable: DIV0
+6 ; - Displaying only divisions with matching criterial in subheader
+7 ;
+8 NEW SDIV
SET SDIV=""
+9 FOR
SET SDIV=$ORDER(^TMP("SCRPW",$JOB,SDIV))
IF SDIV=""!SDOUT
QUIT
Begin DoDot:1
+10 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,DFN))
IF 'DFN!SDOUT
QUIT
Begin DoDot:2
+11 SET (DIV1,DIV0)=0
FOR
SET DIV0=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,DFN,DIV0))
IF 'DIV0
QUIT
Begin DoDot:3
+12 ; Screening "DR" or "PR" levels (SDZ) prior to setting print level
+13 ; Note: Patient must have valid Diagnosis or Procedure to print
+14 IF $GET(^TMP("SCRPW",$JOB,0,1,DFN,DIV0,SDZ))=""
QUIT
+15 SET SDSTOP=SDSTOP+1
IF SDSTOP#1000=0
DO STOP
IF SDOUT
QUIT
+16 SET SDPT0=$GET(^DPT(DFN,0))
SET SDPTNA=$PIECE(SDPT0,U)
+17 IF $LENGTH(SDPTNA)
SET ^TMP("SCRPW",$JOB,SDIV,2,SDPTNA,DFN,DIV0)=$PIECE(SDPT0,U,9)
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;
+19 IF SDOUT
GOTO EXIT
+20 IF $EXTRACT(IOST)="C"
DO DISP0^SCRPW23
+21 KILL SDTIT
+22 SET SDTIT(1)="<*> OUTPATIENT DIAGNOSIS/PROCEDURE CODE SEARCH <*>"
+23 DO HINI^SCRPW46
DO BLD^SCRPW21
+24 SET SDTIT(2)="Report Parameters Selected"
+25 DO HDR
IF SDOUT
GOTO EXIT
DO PD1(0)
IF SDOUT
GOTO EXIT
+26 ;if no data in file, exit from program
+27 IF '$DATA(^TMP("SCRPW",$JOB,0,1))
Begin DoDot:1
+28 KILL SDTIT(2)
DO HDR
IF SDOUT
GOTO EXIT
+29 SET SDX="No activity found within selected report parameters!"
+30 WRITE !!?(IOM-$LENGTH(SDX)\2),SDX
+31 QUIT
End DoDot:1
GOTO EXIT
+32 ;
+33 IF $PIECE(SDDIV,U,2)="SELECTED DIVISIONS"
Begin DoDot:1
+34 SET SDI=0
FOR
SET SDI=$ORDER(SDDIV(SDI))
IF 'SDI
QUIT
SET SDIVL(SDDIV(SDI))=SDI
End DoDot:1
+35 ;
+36 IF $PIECE(SDDIV,U,2)="ALL DIVISIONS"
Begin DoDot:1
+37 SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,0,SDI))
IF 'SDI
QUIT
Begin DoDot:2
+38 SET SDX=$PIECE($GET(^DG(40.8,SDI,0)),U)
+39 IF '$LENGTH(SDX)
SET SDX="***UNKNOWN***"
+40 SET SDIVL(SDX)=SDI
End DoDot:2
End DoDot:1
+41 ;
+42 IF '$DATA(SDIVL)
SET SDIVL($PIECE(SDDIV,U,2))=$PIECE(SDDIV,U)
+43 IF $EXTRACT(IOST)="C"
DO DISP0^SCRPW23
SET SDCOL=$SELECT(IOM=80:0,1:26)
+44 SET SDIVN=""
+45 FOR
SET SDIVN=$ORDER(SDIVL(SDIVN))
IF SDIVN=""!SDOUT
QUIT
DO DPRT(SDIVL(SDIVN))
+46 IF SDOUT
GOTO EXIT
SET SDMD=0
SET SDMD=$ORDER(^TMP("SCRPW",$JOB,SDMD))
SET SDMD=$ORDER(^TMP("SCRPW",$JOB,SDMD))
IF SDMD
DO DPRT(0)
+47 IF $EXTRACT(IOST)="C"
IF 'SDOUT
WRITE !
NEW DIR
SET DIR(0)="E"
DO ^DIR
+48 ;
EXIT DO END^SCRPW50
+1 KILL %,%H,%I,%DT,DFN,DIC,DIR,DTOUT,DUOUT,S1,S2,SD,SDACT,SDAPF,SDBAD,SDC
+2 KILL SDC1,SDCL,SDCOL,SDCPT,SDCRI,SDCT,SDD,SDDIV,SDDX,SDEXE,SDF,SDFF
+3 KILL SDI,SDI2,SDII,SDIII,SDITX,SDIV,SDIVL,SDIVN,SDIXE,SDL,SDL1,SDLAB
+4 KILL SDLAST,SDLF,SDLINE,SDLIST,SDLOC,SDLTH,SDMD,SDNUL,SDOE,SDOE0,SDOTX
+5 KILL SDOUT,SDOXE,SDP,SDPAGE,SDPAR,SDPDIV,SDPNAM,SDPNOW,SDPT0,SDPTNA,SDR
+6 KILL SDR1,SDR2,SDSEL,SDSSN,SDSTOP,SDSTR,SDT,SDTIT,SDTX,SDTXB,SDTY,SDUI
+7 KILL SDUII,SDUIII,SDUIV,SDUJC,SDRESP,SDS1,SDS2,SDV,SDVAL,SDVAR,SDX,SDX2
+8 KILL SDFMT,SDY,SDZ,X,X1,X2,X3,X4,Y,Z
+9 ;EXIT
QUIT
+10 ;
HDR DO HDR^SCRPW46
QUIT
+1 ;
HD1 ;Report subheader
+1 IF SDOUT
QUIT
+2 WRITE !?(SDCOL),"Patient/Division:",?(SDCOL+26),"SSN:"
+3 WRITE ?(SDCOL+38),$SELECT('$DATA(SD("LIST","P")):"Diagnoses:",'$DATA(SD("LIST","D")):"Procedures/Modifiers:",1:"Diagnoses/Procedures:")
+4 WRITE !?(SDCOL),$EXTRACT(SDLINE,1,24),?(SDCOL+26),$EXTRACT(SDLINE,1,10)
+5 WRITE ?(SDCOL+38),$EXTRACT(SDLINE,1,42)
+6 ;HD1
QUIT
+7 ;
STOP ;Check for stop task request
+1 IF $DATA(ZTQUEUED)
SET (SDOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)
QUIT
+2 ;
DPRT(SDV) ;Print report for a division
+1 ;Required input: SDV=division ifn or '0' for summary
+2 ;copying division #
SET SDIV=SDV
+3 DO DHDR^SCRPW46(SDV,2,.SDTIT)
SET SDPAGE=1
DO HDR
IF SDOUT
QUIT
+4 IF '$DATA(^TMP("SCRPW",$JOB,SDV,2))
Begin DoDot:1
+5 SET SDX="No activity found within selected report parameters for this division!"
+6 WRITE !!?(IOM-$LENGTH(SDX)\2),SDX
QUIT
End DoDot:1
+7 DO HD1
SET (SDCT,SDDCT,DIVB)=0
SET (SDPNAM,SDPNAM2)=""
SET SDF=$PIECE(SDFMT,U)
+8 FOR
SET SDPNAM=$ORDER(^TMP("SCRPW",$JOB,SDV,2,SDPNAM))
IF SDPNAM=""!SDOUT
QUIT
Begin DoDot:1
+9 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,SDV,2,SDPNAM,DFN))
IF 'DFN!SDOUT
QUIT
Begin DoDot:2
+10 SET SDCT=SDCT+1
SET DIV0=0
+11 FOR
SET DIV0=$ORDER(^TMP("SCRPW",$JOB,SDV,2,SDPNAM,DFN,DIV0))
IF DIV0=""
QUIT
Begin DoDot:3
+12 SET SDDCT=SDDCT+1
SET SDSSN=^TMP("SCRPW",$JOB,SDV,2,SDPNAM,DFN,DIV0)
+13 SET SDPNAM2=SDPNAM_" "_DIV0
+14 DO DPRT1
WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
+15 WRITE !?(SDCOL),$EXTRACT(SDLINE,1,80)
+16 WRITE !?(SDCOL),"TOTAL PATIENTS IDENTIFIED: ",SDCT
+17 IF SDV=0
WRITE !?(SDCOL),"MULTI-DIVISION PATIENTS: ",SDDCT-SDCT
+18 QUIT
+19 ;
DPRT1 ;Prints name & ss# of line detail
+1 IF $Y>(IOSL-6)
DO HDR
DO HD1
IF SDOUT
QUIT
+2 WRITE !?(SDCOL),$EXTRACT(SDPNAM2,1,24)
+3 WRITE ?(SDCOL+26),SDSSN
+4 SET SDLF=0
+5 ;
+6 ;Calling print format modules
Begin DoDot:1
+7 DO PATIENT
+8 IF SDF="V"
DO VISIT
QUIT
+9 IF SDF="E"
DO ENCNTR
QUIT
+10 QUIT
End DoDot:1
+11 ;DPRT1
QUIT
+12 ;
PATIENT ;Prints Patient Diagnosis/Procedures for all Types of Detail
+1 FOR SDI="DR","PR"
IF $DATA(^TMP("SCRPW",$JOB,0,1,DFN,DIV0,SDI))
Begin DoDot:1
+2 SET SDII=""
FOR
SET SDII=$ORDER(^TMP("SCRPW",$JOB,0,1,DFN,DIV0,SDI,SDII))
IF SDII=""!SDOUT
QUIT
Begin DoDot:2
+3 IF $Y>(IOSL-4)
DO HDR
DO HD1
IF SDOUT
QUIT
+4 Begin DoDot:3
+5 IF SDLF
WRITE !
QUIT
+6 IF DIV1'=DIV0
SET DIV1=DIV0
WRITE !
QUIT
+7 QUIT
End DoDot:3
+8 WRITE ?(SDCOL+38),$EXTRACT($SELECT(SDI="DR":"Dx: ",1:"Proc.: ")_SDII,1,42)
SET SDLF=1
+9 ; print mod and desc for current CPT (SDII)
+10 ; SDII2 = modifier and description
+11 IF $DATA(^TMP("SCRPW",$JOB,0,1,DFN,DIV0,SDI,SDII))
Begin DoDot:3
+12 NEW SDII2
SET SDII2=""
+13 FOR
SET SDII2=$ORDER(^TMP("SCRPW",$JOB,0,1,DFN,DIV0,SDI,SDII,SDII2))
IF 'SDII2
QUIT
Begin DoDot:4
+14 IF $Y>(IOSL-4)
DO HDR
DO HD1
IF SDOUT
QUIT
+15 WRITE !,?(SDCOL+47),"-",$EXTRACT(SDII2,1,32)
End DoDot:4
End DoDot:3
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
IF SDOUT
QUIT
+18 SET SDI=0
FOR
SET SDI=$ORDER(SDAPF(2,SDI))
IF 'SDI!SDOUT
QUIT
SET SDOE0=U_DFN_U
SET SDY=SDAPF(2,SDI)
DO APF(SDY,SDOE0,5)
+19 ;
+20 ;PATIENT
QUIT
+21 ;
VISIT ;Printing Type of Detail: Visits
+1 SET SDT=0
+2 FOR
SET SDT=$ORDER(^TMP("SCRPW",$JOB,0,1,DFN,DIV0,"ACT",SDT))
IF 'SDT!SDOUT
QUIT
Begin DoDot:1
+3 IF $Y>(IOSL-4)
DO HDR
DO HD1
IF SDOUT
QUIT
+4 SET Y=SDT
XECUTE ^DD("DD")
WRITE !?(SDCOL+10),"Visit: ",Y
QUIT
End DoDot:1
+5 ;
+6 ;VISIT
QUIT
+7 ;
ENCNTR ;Printing Type of Detail: ENCOUNTER
+1 SET SDT=0
+2 FOR
SET SDT=$ORDER(^TMP("SCRPW",$JOB,0,1,DFN,DIV0,"ACT",SDT))
IF 'SDT!SDOUT
QUIT
Begin DoDot:1
+3 SET SDOE=0
FOR
SET SDOE=$ORDER(^TMP("SCRPW",$JOB,0,1,DFN,DIV0,"ACT",SDT,SDOE))
IF 'SDOE!SDOUT
QUIT
Begin DoDot:2
+4 IF $Y>(IOSL-4)
DO HDR
DO HD1
IF SDOUT
QUIT
+5 SET SDOE0=^TMP("SCRPW",$JOB,0,1,DFN,DIV0,"ACT",SDT,SDOE)
+6 SET SDLOC=$PIECE($GET(^SC(+$PIECE(SDOE0,U,4),0)),U)
+7 SET Y=SDT
XECUTE ^DD("DD")
WRITE !?(SDCOL+10),"Encounter: ",$PIECE(Y,":",1,2)
+8 WRITE ?(SDCOL+40),SDLOC
+9 SET SDI=0
FOR
SET SDI=$ORDER(SDAPF(1,SDI))
IF 'SDI!SDOUT
QUIT
SET SDY=SDAPF(1,SDI)
DO APF(SDY,SDOE0,$SELECT($DATA(SDAPF(2)):15,1:25))
+10 QUIT
End DoDot:2
End DoDot:1
+11 ;ENCNTR
QUIT
+12 ;
APF(SDY,SDOE0,SDC) ;Print additional print fields
+1 ;Required input: SDY=action acronym^major category^minor category
+2 ;Required input: SDOE0=zeroeth node of OUTPATIENT ENCOUNTER record
+3 ;Required input: SDC=column to begin output
+4 NEW SDACT,SDX,SDI
+5 IF $Y>(IOSL-4)
DO HDR
DO HD1
IF SDOUT
QUIT
WRITE !?(SDCOL+SDC),$PIECE(SDY,U,3),":"
+6 SET SDACT=^TMP("SCRPW",$JOB,"ACT",$PIECE(SDY,U))
SET SDLF=0
SET SDC1=SDC+2+$LENGTH($PIECE(SDY,U,3))
+7 KILL SDX
XECUTE $PIECE(SDACT,"~",7)
SET SDX=""
FOR
SET SDX=$ORDER(SDX(SDX))
IF SDX=""!SDOUT
QUIT
Begin DoDot:1
+8 IF $Y>(IOSL-3)
DO HDR
DO HD1
IF SDOUT
QUIT
IF SDLF
WRITE !
WRITE ?(SDCOL+SDC1),$EXTRACT($PIECE(SDX(SDX),U,2),1,(80-SDC1))
SET SDLF=1
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
PD1(SDI) ;Print parameters
+1 ;Required input: SDI=0 for all division selections or division ifn
+2 NEW SDLF,C
SET C=(IOM-80\2)
SET SDLF=0
IF SDI
DO PDP("Report for",SDDIV(SDI),1)
IF SDOUT
QUIT
+3 IF 'SDI
DO PDP("Report for",SDDIV,2)
IF SDOUT
QUIT
Begin DoDot:1
+4 FOR
SET SDI=$ORDER(SDDIV(SDI))
IF 'SDI!SDOUT
QUIT
DO PDP("Division",SDDIV(SDI),1)
End DoDot:1
+5 IF SDOUT
QUIT
DO PDP("Beginning date",SD("PBDT"),1,0,1)
IF SDOUT
QUIT
DO PDP("Ending date",SD("PEDT"),1)
IF SDOUT
QUIT
+6 SET SDI=""
FOR
SET SDI=$ORDER(SDPAR(SDI))
IF SDI=""!SDOUT
QUIT
Begin DoDot:1
+7 DO PDP("Search element '"_SDI_"'",SDPAR(SDI),2,0,1)
IF SDOUT
QUIT
SET SDTY=$PIECE(SDPAR(SDI),U)
+8 IF SDTY["L"
SET SDLAB=$SELECT(SDTY["D":"Diagnosis",1:"Procedure")
SET SDII=0
FOR
SET SDII=$ORDER(SDPAR(SDI,SDII))
IF 'SDII
QUIT
DO PDP(SDLAB,SDPAR(SDI,SDII),1)
IF SDOUT
QUIT
+9 IF SDTY["R"
SET SDVAL=$ORDER(SDPAR(SDI,""))
DO PDP("From",SDVAL,1)
IF SDOUT
QUIT
SET SDVAL=$ORDER(SDPAR(SDI,SDVAL))
DO PDP("To",SDVAL,1)
+10 QUIT
End DoDot:1
+11 SET SDI=""
FOR
SET SDI=$ORDER(SDCRI(SDI))
IF SDI=""!SDOUT
QUIT
Begin DoDot:1
+12 DO PDP("Combine logic",SDI,1,0,1)
IF SDOUT
QUIT
MERGE SDITX=SDCRI(SDI)
DO WRAP^SCRPW45(.SDITX,.SDOTX,,,60,"")
SET SDII=""
FOR
SET SDII=$ORDER(SDOTX(SDII))
IF SDII=""!SDOUT
QUIT
Begin DoDot:2
+13 SET SDLF=SDLF+1
IF $EXTRACT(IOST)="C"
IF SDLF#18=0
DO WAIT
IF SDOUT
QUIT
+14 IF $Y>(IOSL-3)
IF $EXTRACT(IOST)="P"
DO HDR
IF SDOUT
QUIT
+15 SET SDX=SDOTX(SDII)
WRITE !?(IOM-$LENGTH(SDX)\2),SDX
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 DO PDP("Type of detail",SDFMT,2,0,1)
IF SDOUT
QUIT
+19 SET SDIII=0
FOR SDI=2,1
SET SDII=0
FOR
SET SDII=$ORDER(SDAPF(SDI,SDII))
IF 'SDII!SDOUT
QUIT
Begin DoDot:1
+20 DO PDP("Additional print fields",SDAPF(SDI,SDII),3,SDIII,'SDIII)
SET SDIII=1
End DoDot:1
+21 IF $EXTRACT(IOST)="C"
DO WAIT
QUIT
+22 ;
PDP(SDT,SDX,SDP,SDL,SDL1) ;Print parameter display line
+1 ;Required input: SDT=parameter title
+2 ;Required input: SDX=parameter value
+3 ;Required input: SDP=$P of SDX to print
+4 ;Optional input: SDL=1 to suppress title and do line feed
+5 ;Optional input: SDL1=1 to do additional line feed
+6 SET SDLF=SDLF+1
IF $EXTRACT(IOST)="C"
IF SDLF#18=0
DO WAIT
IF SDOUT
QUIT
+7 IF $Y>(IOSL-3)
IF $EXTRACT(IOST)="P"
DO HDR
IF SDOUT
QUIT
+8 IF $GET(SDL1)
WRITE !
SET SDLF=SDLF+1
IF $EXTRACT(IOST)="C"
IF SDLF#18=0
DO WAIT
IF SDOUT
QUIT
+9 WRITE !
IF '$GET(SDL)
WRITE $JUSTIFY(SDT,(IOM-6\2)),":"
WRITE ?(IOM\2-1),$PIECE(SDX,U,SDP)
QUIT
+10 ;
WAIT ;Do CRT pause
+1 NEW DIR
WRITE !
SET DIR(0)="E"
DO ^DIR
SET SDOUT=Y'=1
WRITE !
QUIT
