SCRPW46 ;RENO/KEITH/MLR - Outpatient Diagnosis/Procedure Search (cont.) ;9/27/00 10:29am
;;5.3;Scheduling;**144,180,199,295,324,351,593**;AUG 13, 1993;Build 13
; *199*
; - Creation of Division subscript in ^TMP after DFN to capture,
; display, & count multi-divisional patients in Summary Section.
; - Filtering out on Sub-header those Division names not having
; patients meeting search criteria.
;
PDIS ;Parameter display
D SUBT^SCRPW50("**** Report Parameters Selected ****")
W ! D PD1^SCRPW47(0) S SDOUT=0
;
PDIS1 K DIR
S DIR(0)="S^C:CONTINUE;R:RE-DISPLAY PARAMETERS;P:PRINT PARAMETERS;Q:QUIT"
S DIR("A")="Select report action"
S DIR("B")="CONTINUE"
D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
Q:Y="C" G:Y="R" PDIS I Y="Q" S SDOUT=1 Q
N ZTSAVE
F SDI="SDDIV","SDDIV(","SD(","SDPAR(","SDCRI(","SDFMT","SDAPF(" S ZTSAVE(SDI)=""
W ! D EN^XUTMDEVQ("PPRT^SCRPW46","Print Report Parameters",.ZTSAVE)
G PDIS1
;
PPRT ;Print report parameters
D:$E(IOST)="C" DISP0^SCRPW23
S SDTIT(1)="<*> OUTPATIENT DIAGNOSTIC/PROCEDURE CODE SEARCH <*>"
S SDTIT(2)="Report Search Parameters" D HINI,HDR
D:'SDOUT PD1^SCRPW47(0) I $E(IOST)="P",$D(ZTQUEUED) G EXIT^SCRPW47
Q ;PPRT
;
STOP ;Check for stop task request
S:$D(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
;
HINI ;Initialize header variables
S SDLINE="",$P(SDLINE,"-",(IOM+1))=""
D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDPAGE=1,SDFF=0 Q
;
HDR ;Print report header
I $E(IOST)="C",SDFF N DIR S DIR(0)="E" W ! D ^DIR S SDOUT=Y'=1 Q:SDOUT
D STOP Q:SDOUT
I SDFF!('SDFF&($E(IOST)="C")) W $$XY^SCRPW50(IOF,1,0)
I $X W $$XY^SCRPW50("",0,0)
N SDI W SDLINE S SDI=0
F S SDI=$O(SDTIT(SDI)) Q:'SDI W !?(IOM-$L(SDTIT(SDI))\2),SDTIT(SDI)
W !,SDLINE,!,"For date range: ",SD("PBDT")," to ",SD("PEDT")
W !,"Date printed: ",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE
W !,SDLINE S SDPAGE=SDPAGE+1,SDFF=1
Q ;HDR
;
DHDR(SDIV,SDI,SDTIT) ;Set up division subheaders
;Required input: SDIV=division ifn or '0' for summary
;Required input: SDI=array number to start with
;Required input: SDTIT=array to store subheaders in (pass by reference)
D ;
. I 'SDIV S SDTIT(SDI)="Summary for "_$P(SDDIV,U,2) Q
. I SDDIV,($P(SDDIV,U,2)="ALL DIVISIONS") S SDTIT(SDI)="For division: "_SDIVN_" "_SDIVL(SDIVN) Q ; SD*5.3*324
. S SDTIT(SDI)="For facility: "_SDIVN Q
;S SDTIT(SDI)=$S('SDIV:"Summary for "_$P(SDDIV,U,2),SDDIV!($P(SDDIV,U,2)="ALL DIVISIONS"):"For division: "_SDIVN_" "_SDIVL(SDIVN),1:"For facility: "_SDIVN)
;
I 'SDIV,$P(SDDIV,U,2)="SELECTED DIVISIONS" N SDIVN S SDIVN="" D Q
.F S SDIVN=$O(SDDIV(SDIVN)) Q:SDIVN="" S SDI=SDI+1,SDTIT(SDI)="Division: "_SDDIV(SDIVN)
.Q
;
I 'SDIV,$P(SDDIV,U,2)="ALL DIVISIONS" D
.N SDIV S SDIV=0 F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:'SDIV D
.. Q:'$D(^TMP("SCRPW",$J,SDIV,2))
.. S SDI=SDI+1
.. S SDTIT(SDI)="Division: "_$P($G(^DG(40.8,SDIV,0)),U)_" "_SDIV
.Q
Q
;
START ;Print report
K ^TMP("SCRPW",$J) S (SDOUT,SDSTOP)=0,SDMD="",SDMD=$O(SDDIV(SDMD)),SDMD=$O(SDDIV(SDMD)) S:$P(SDDIV,U,2)="ALL DIVISIONS" SDMD=1
;Iterate through list of patient encounters
S DFN=0 F S DFN=$O(^SCE("ADFN",DFN)) Q:'DFN K SDPDIV S SDSTOP=SDSTOP+1 D:SDSTOP#100=0 STOP Q:SDOUT D
.S SDT=SD("BDT") F S SDT=$O(^SCE("ADFN",DFN,SDT)) Q:'SDT!SDOUT!(SDT>SD("EDT")) D
..S SDOE=0 F S SDOE=$O(^SCE("ADFN",DFN,SDT,SDOE)) Q:'SDOE!SDOUT D
...S SDOE0=$$GETOE^SDOE(SDOE) S SDIV=$P(SDOE0,"^",11) Q:'SDIV!$P(SDOE0,"^",6)!'$$DIV() S SDPDIV(SDIV)=""
...;Build initial patient diagnosis/procedure lists
...I $D(SD("LIST","D")) K SDLIST D GETDX^SDOE(SDOE,"SDLIST") S SDI=0 F S SDI=$O(SDLIST(SDI)) Q:'SDI D
....S SDDX=$P(SDLIST(SDI),"^") S:SDDX ^TMP("SCRPW",$J,0,0,DFN,SDIV,"DX",SDDX)=""
....Q
...I $D(SD("LIST","P")) K SDLIST D GETCPT^SDOE(SDOE,"SDLIST") S SDI=0 F S SDI=$O(SDLIST(SDI)) Q:'SDI D
....S SDCPT=$P(SDLIST(SDI),"^") S:SDCPT ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDCPT)=""
....;Loop through modifiers and add to CPT array
.... N SDMODN,SDMOD ; SDMODN=modifier node, SDMOD=mod pointer
.... S SDMODN=0
.... F S SDMODN=+$O(SDLIST(SDI,1,SDMODN)) Q:'SDMODN D
..... S SDMOD=$P(SDLIST(SDI,1,SDMODN,0),"^",1)
..... S:SDMOD ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDCPT,SDMOD)=""
..... Q
.... Q
...S:$P(SDFMT,"^")="E" ^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT",SDT,SDOE)=SDOE0
...S:$P(SDFMT,"^")="V" ^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT",$P(SDT,"."))=""
...S:$P(SDFMT,"^")="P" ^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT")=""
...Q
..Q
.I '$D(^TMP("SCRPW",$J,0,0,DFN)) D Q
..N SDIV S SDIV="" F S SDIV=$O(SDPDIV(SDIV)) Q:SDIV="" K ^TMP("SCRPW",$J,SDIV,1,DFN)
..Q
.;Build text lists for Diagnosis ranges if necessary
.I $D(SD("LIST","D","R")) D
.. N SDIV S SDIV="" F S SDIV=$O(SDPDIV(SDIV)) Q:'SDIV D
... S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"DX",SDI)) Q:'SDI D
....S SDX=$$ICDDX^SCRPWICD(SDI,+SDOE0),SDX=$P(SDX,"^",2)_" "_$P(SDX,"^",4)
.... S:$L(SDX)>1 ^TMP("SCRPW",$J,0,0,DFN,SDIV,"DXR",SDX)=SDI
.;Building text list for Procedure ranges
.I $D(SD("LIST","P","R")) S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDI)) Q:'SDI D
..; SDI=CPT pointer, SDI2=mod ptr, SDX=CPT+desc, SDX2=mod+desc
..; get CPT and description and build array entry
.. N CPTINFO,CPTCODE,CPTTEXT
.. S CPTINFO=$$CPT^ICPTCOD(SDI,+SDOE0,1)
.. Q:CPTINFO'>0
.. S CPTCODE=$P(CPTINFO,"^",2)
.. S CPTTEXT=$P(CPTINFO,"^",3)
.. S SDX=CPTCODE_" "_CPTTEXT
.. S:$L(SDX)>1 ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPTR",SDX)=SDI
..;
..; loop through mods in CPT array and call API to get mod code/desc
.. S SDI2="" F S SDI2=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDI,SDI2)) Q:'SDI2 D
... N MODINFO,MODCODE,MODTEXT
... S MODINFO=$$MOD^ICPTMOD(SDI2,"I",+SDOE0,1)
... Q:MODINFO'>0
... S MODCODE=$P(MODINFO,"^",2)
... S MODTEXT=$P(MODINFO,"^",3)
... S SDX2=MODCODE_" "_MODTEXT
... ; add mod code/desc to array
... S:$L(SDX2)>1 ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPTR",SDX,SDX2)=SDI2
... Q
..Q
.;Iterate through criteria combine logic
.;Loop through secondary Division (SDIV) for multiple division episodes
. N SDIV S SDIV="" F S SDIV=$O(SDPDIV(SDIV)) Q:SDIV="" D
.. S SDCRI="" F S SDCRI=$O(SDCRI(SDCRI)) Q:SDCRI="" D
... S SDCL=$TR($TR(SDCRI,"'",""),"&","") F SDI=1:1:$L(SDCL) S SDC=$E(SDCL,SDI) D:'$D(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC))
....;Build list of true items for each criteria element
.... S SDZ=$P(SDPAR(SDC),"^")
.... I SDZ="DL" S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"DX",SDI)) Q:'SDI D
..... S:$D(SDPAR(SDC,SDI)) ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC,SDI)=""
..... Q
.... I SDZ="DR" S SDR1="",SDR1=$O(SDPAR(SDC,SDR1)),SDR2=$O(SDPAR(SDC,SDR1)),SDI="" D
..... F S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"DXR",SDI)) Q:SDI="" D
...... I SDR1']SDI,SDI']SDR2 S ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC,SDI)="" Q
..... Q
.... I SDZ="PL" S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDI)) Q:'SDI D
..... I $D(SDPAR(SDC,SDI)) M ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC,SDI)=^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDI)
..... Q
.... I SDZ="PR" S SDR1="",SDR1=$O(SDPAR(SDC,SDR1)),SDR2=$O(SDPAR(SDC,SDR1)),SDI="" D
..... F S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPTR",SDI)) Q:SDI="" D
...... I SDR1']SDI,SDI']SDR2 M ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC,SDI)=^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPTR",SDI)
......Q
.....Q
....S ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC)=($D(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC))>0)_U_SDZ
.... Q
...;Apply criteria combine logic
...N A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z
...F SDI=1:1:$L(SDCL) S SDC=$E(SDCL,SDI),@SDC=$P(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC),"^")
...;If combine logic is "true", move items to final list
...I @SDCRI F SDI=1:1:$L(SDCL) S SDC=$E(SDCL,SDI),SDX=^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC) D
....I SDX M ^TMP("SCRPW",$J,0,1,DFN,SDIV,$P(SDX,"^",2))=^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC)
....Q
...Q
.I '$D(^TMP("SCRPW",$J,0,1,DFN)) D Q
..S SDIV="" F S SDIV=$O(SDPDIV(SDIV)) Q:SDIV="" K ^TMP("SCRPW",$J,SDIV,1,DFN)
..Q
.;Move item ifn lists to text lists
.N SDIV S SDIV="" F S SDIV=$O(SDPDIV(SDIV)) Q:SDIV="" D
.. S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,0,1,DFN,SDIV,"DL",SDI)) Q:'SDI D
... S SDX=$$ICDDX^SCRPWICD(SDI,+SDOE0),SDX=$P(SDX,"^",2)_" "_$P(SDX,"^",4) S:$L(SDX)>1 ^TMP("SCRPW",$J,0,1,DFN,SDIV,"DR",SDX)=$G(SDT)
... Q
.N SDIV S SDIV="" F S SDIV=$O(SDPDIV(SDIV)) Q:SDIV="" D
.. S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,0,1,DFN,SDIV,"PL",SDI)) Q:'SDI D
... N CPTINFO,CPTCODE,CPTTEXT
... S CPTINFO=$$CPT^ICPTCOD(SDI,+SDOE0,1)
... Q:CPTINFO'>0
... S CPTCODE=$P(CPTINFO,"^",2)
... S CPTTEXT=$P(CPTINFO,"^",3)
... S SDX=CPTCODE_" "_CPTTEXT
... S:$L(SDX)>1 ^TMP("SCRPW",$J,0,1,DFN,SDIV,"PR",SDX)=""
... ;
... ;loop through mods in CPT array and call API to get mod code/desc
... S SDI2=""
... F S SDI2=$O(^TMP("SCRPW",$J,0,1,DFN,SDIV,"PL",SDI,SDI2)) Q:'SDI2 D
.... N MODINFO,MODCODE,MODTEXT
.... S MODINFO=$$MOD^ICPTMOD(SDI2,"I",+SDOE0,1)
.... Q:MODINFO'>0
.... S MODCODE=$P(MODINFO,"^",2)
.... S MODTEXT=$P(MODINFO,"^",3)
.... S SDX2=MODCODE_" "_MODTEXT
.... ; add mod code/desc to array
.... S:$L(SDX2)>1 ^TMP("SCRPW",$J,0,1,DFN,SDIV,"PR",SDX,SDX2)=""
.... Q
...Q
. ; delete procedure list array
. N SDIV S SDIV="" F S SDIV=$O(SDPDIV(SDIV)) Q:SDIV="" D
..;Merge activity list
.. M ^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT")=^TMP("SCRPW",$J,SDIV,0,DFN,SDIV,"ACT")
..;Kill scratch list, merge to summary global if multidivisional
..I SDMD,SDFMT'="P" M ^TMP("SCRPW",$J,0,1,DFN,SDIV,"ACT")=^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT")
..;Delete scratch levels and arrays after merge
.. K ^TMP("SCRPW",$J,0,1,DFN,"DL")
.. K ^TMP("SCRPW",$J,0,1,DFN,"PL")
..Q
.Q
;Delete 0,0 scratch level prior to printing
K ^TMP("SCRPW",$J,0,0)
G:SDOUT EXIT^SCRPW47 G ^SCRPW47
;
DIV() ;Check division
Q:'SDDIV 1 Q $D(SDDIV(+SDIV))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW46 10004 printed Dec 13, 2024@02:43:47 Page 2
SCRPW46 ;RENO/KEITH/MLR - Outpatient Diagnosis/Procedure Search (cont.) ;9/27/00 10:29am
+1 ;;5.3;Scheduling;**144,180,199,295,324,351,593**;AUG 13, 1993;Build 13
+2 ; *199*
+3 ; - Creation of Division subscript in ^TMP after DFN to capture,
+4 ; display, & count multi-divisional patients in Summary Section.
+5 ; - Filtering out on Sub-header those Division names not having
+6 ; patients meeting search criteria.
+7 ;
PDIS ;Parameter display
+1 DO SUBT^SCRPW50("**** Report Parameters Selected ****")
+2 WRITE !
DO PD1^SCRPW47(0)
SET SDOUT=0
+3 ;
PDIS1 KILL DIR
+1 SET DIR(0)="S^C:CONTINUE;R:RE-DISPLAY PARAMETERS;P:PRINT PARAMETERS;Q:QUIT"
+2 SET DIR("A")="Select report action"
+3 SET DIR("B")="CONTINUE"
+4 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SDOUT=1
QUIT
+5 if Y="C"
QUIT
if Y="R"
GOTO PDIS
IF Y="Q"
SET SDOUT=1
QUIT
+6 NEW ZTSAVE
+7 FOR SDI="SDDIV","SDDIV(","SD(","SDPAR(","SDCRI(","SDFMT","SDAPF("
SET ZTSAVE(SDI)=""
+8 WRITE !
DO EN^XUTMDEVQ("PPRT^SCRPW46","Print Report Parameters",.ZTSAVE)
+9 GOTO PDIS1
+10 ;
PPRT ;Print report parameters
+1 if $EXTRACT(IOST)="C"
DO DISP0^SCRPW23
+2 SET SDTIT(1)="<*> OUTPATIENT DIAGNOSTIC/PROCEDURE CODE SEARCH <*>"
+3 SET SDTIT(2)="Report Search Parameters"
DO HINI
DO HDR
+4 if 'SDOUT
DO PD1^SCRPW47(0)
IF $EXTRACT(IOST)="P"
IF $DATA(ZTQUEUED)
GOTO EXIT^SCRPW47
+5 ;PPRT
QUIT
+6 ;
STOP ;Check for stop task request
+1 if $DATA(ZTQUEUED)
SET (SDOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)
QUIT
+2 ;
HINI ;Initialize header variables
+1 SET SDLINE=""
SET $PIECE(SDLINE,"-",(IOM+1))=""
+2 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET SDPNOW=$PIECE(Y,":",1,2)
SET SDPAGE=1
SET SDFF=0
QUIT
+3 ;
HDR ;Print report header
+1 IF $EXTRACT(IOST)="C"
IF SDFF
NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
SET SDOUT=Y'=1
if SDOUT
QUIT
+2 DO STOP
if SDOUT
QUIT
+3 IF SDFF!('SDFF&($EXTRACT(IOST)="C"))
WRITE $$XY^SCRPW50(IOF,1,0)
+4 IF $X
WRITE $$XY^SCRPW50("",0,0)
+5 NEW SDI
WRITE SDLINE
SET SDI=0
+6 FOR
SET SDI=$ORDER(SDTIT(SDI))
if 'SDI
QUIT
WRITE !?(IOM-$LENGTH(SDTIT(SDI))\2),SDTIT(SDI)
+7 WRITE !,SDLINE,!,"For date range: ",SD("PBDT")," to ",SD("PEDT")
+8 WRITE !,"Date printed: ",SDPNOW,?(IOM-6-$LENGTH(SDPAGE)),"Page: ",SDPAGE
+9 WRITE !,SDLINE
SET SDPAGE=SDPAGE+1
SET SDFF=1
+10 ;HDR
QUIT
+11 ;
DHDR(SDIV,SDI,SDTIT) ;Set up division subheaders
+1 ;Required input: SDIV=division ifn or '0' for summary
+2 ;Required input: SDI=array number to start with
+3 ;Required input: SDTIT=array to store subheaders in (pass by reference)
+4 ;
Begin DoDot:1
+5 IF 'SDIV
SET SDTIT(SDI)="Summary for "_$PIECE(SDDIV,U,2)
QUIT
+6 ; SD*5.3*324
IF SDDIV
IF ($PIECE(SDDIV,U,2)="ALL DIVISIONS")
SET SDTIT(SDI)="For division: "_SDIVN_" "_SDIVL(SDIVN)
QUIT
+7 SET SDTIT(SDI)="For facility: "_SDIVN
QUIT
End DoDot:1
+8 ;S SDTIT(SDI)=$S('SDIV:"Summary for "_$P(SDDIV,U,2),SDDIV!($P(SDDIV,U,2)="ALL DIVISIONS"):"For division: "_SDIVN_" "_SDIVL(SDIVN),1:"For facility: "_SDIVN)
+9 ;
+10 IF 'SDIV
IF $PIECE(SDDIV,U,2)="SELECTED DIVISIONS"
NEW SDIVN
SET SDIVN=""
Begin DoDot:1
+11 FOR
SET SDIVN=$ORDER(SDDIV(SDIVN))
if SDIVN=""
QUIT
SET SDI=SDI+1
SET SDTIT(SDI)="Division: "_SDDIV(SDIVN)
+12 QUIT
End DoDot:1
QUIT
+13 ;
+14 IF 'SDIV
IF $PIECE(SDDIV,U,2)="ALL DIVISIONS"
Begin DoDot:1
+15 NEW SDIV
SET SDIV=0
FOR
SET SDIV=$ORDER(^TMP("SCRPW",$JOB,SDIV))
if 'SDIV
QUIT
Begin DoDot:2
+16 if '$DATA(^TMP("SCRPW",$JOB,SDIV,2))
QUIT
+17 SET SDI=SDI+1
+18 SET SDTIT(SDI)="Division: "_$PIECE($GET(^DG(40.8,SDIV,0)),U)_" "_SDIV
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
START ;Print report
+1 KILL ^TMP("SCRPW",$JOB)
SET (SDOUT,SDSTOP)=0
SET SDMD=""
SET SDMD=$ORDER(SDDIV(SDMD))
SET SDMD=$ORDER(SDDIV(SDMD))
if $PIECE(SDDIV,U,2)="ALL DIVISIONS"
SET SDMD=1
+2 ;Iterate through list of patient encounters
+3 SET DFN=0
FOR
SET DFN=$ORDER(^SCE("ADFN",DFN))
if 'DFN
QUIT
KILL SDPDIV
SET SDSTOP=SDSTOP+1
if SDSTOP#100=0
DO STOP
if SDOUT
QUIT
Begin DoDot:1
+4 SET SDT=SD("BDT")
FOR
SET SDT=$ORDER(^SCE("ADFN",DFN,SDT))
if 'SDT!SDOUT!(SDT>SD("EDT"))
QUIT
Begin DoDot:2
+5 SET SDOE=0
FOR
SET SDOE=$ORDER(^SCE("ADFN",DFN,SDT,SDOE))
if 'SDOE!SDOUT
QUIT
Begin DoDot:3
+6 SET SDOE0=$$GETOE^SDOE(SDOE)
SET SDIV=$PIECE(SDOE0,"^",11)
if 'SDIV!$PIECE(SDOE0,"^",6)!'$$DIV()
QUIT
SET SDPDIV(SDIV)=""
+7 ;Build initial patient diagnosis/procedure lists
+8 IF $DATA(SD("LIST","D"))
KILL SDLIST
DO GETDX^SDOE(SDOE,"SDLIST")
SET SDI=0
FOR
SET SDI=$ORDER(SDLIST(SDI))
if 'SDI
QUIT
Begin DoDot:4
+9 SET SDDX=$PIECE(SDLIST(SDI),"^")
if SDDX
SET ^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"DX",SDDX)=""
+10 QUIT
End DoDot:4
+11 IF $DATA(SD("LIST","P"))
KILL SDLIST
DO GETCPT^SDOE(SDOE,"SDLIST")
SET SDI=0
FOR
SET SDI=$ORDER(SDLIST(SDI))
if 'SDI
QUIT
Begin DoDot:4
+12 SET SDCPT=$PIECE(SDLIST(SDI),"^")
if SDCPT
SET ^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CPT",SDCPT)=""
+13 ;Loop through modifiers and add to CPT array
+14 ; SDMODN=modifier node, SDMOD=mod pointer
NEW SDMODN,SDMOD
+15 SET SDMODN=0
+16 FOR
SET SDMODN=+$ORDER(SDLIST(SDI,1,SDMODN))
if 'SDMODN
QUIT
Begin DoDot:5
+17 SET SDMOD=$PIECE(SDLIST(SDI,1,SDMODN,0),"^",1)
+18 if SDMOD
SET ^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CPT",SDCPT,SDMOD)=""
+19 QUIT
End DoDot:5
+20 QUIT
End DoDot:4
+21 if $PIECE(SDFMT,"^")="E"
SET ^TMP("SCRPW",$JOB,SDIV,1,DFN,SDIV,"ACT",SDT,SDOE)=SDOE0
+22 if $PIECE(SDFMT,"^")="V"
SET ^TMP("SCRPW",$JOB,SDIV,1,DFN,SDIV,"ACT",$PIECE(SDT,"."))=""
+23 if $PIECE(SDFMT,"^")="P"
SET ^TMP("SCRPW",$JOB,SDIV,1,DFN,SDIV,"ACT")=""
+24 QUIT
End DoDot:3
+25 QUIT
End DoDot:2
+26 IF '$DATA(^TMP("SCRPW",$JOB,0,0,DFN))
Begin DoDot:2
+27 NEW SDIV
SET SDIV=""
FOR
SET SDIV=$ORDER(SDPDIV(SDIV))
if SDIV=""
QUIT
KILL ^TMP("SCRPW",$JOB,SDIV,1,DFN)
+28 QUIT
End DoDot:2
QUIT
+29 ;Build text lists for Diagnosis ranges if necessary
+30 IF $DATA(SD("LIST","D","R"))
Begin DoDot:2
+31 NEW SDIV
SET SDIV=""
FOR
SET SDIV=$ORDER(SDPDIV(SDIV))
if 'SDIV
QUIT
Begin DoDot:3
+32 SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"DX",SDI))
if 'SDI
QUIT
Begin DoDot:4
+33 SET SDX=$$ICDDX^SCRPWICD(SDI,+SDOE0)
SET SDX=$PIECE(SDX,"^",2)_" "_$PIECE(SDX,"^",4)
+34 if $LENGTH(SDX)>1
SET ^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"DXR",SDX)=SDI
End DoDot:4
End DoDot:3
End DoDot:2
+35 ;Building text list for Procedure ranges
+36 IF $DATA(SD("LIST","P","R"))
SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CPT",SDI))
if 'SDI
QUIT
Begin DoDot:2
+37 ; SDI=CPT pointer, SDI2=mod ptr, SDX=CPT+desc, SDX2=mod+desc
+38 ; get CPT and description and build array entry
+39 NEW CPTINFO,CPTCODE,CPTTEXT
+40 SET CPTINFO=$$CPT^ICPTCOD(SDI,+SDOE0,1)
+41 if CPTINFO'>0
QUIT
+42 SET CPTCODE=$PIECE(CPTINFO,"^",2)
+43 SET CPTTEXT=$PIECE(CPTINFO,"^",3)
+44 SET SDX=CPTCODE_" "_CPTTEXT
+45 if $LENGTH(SDX)>1
SET ^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CPTR",SDX)=SDI
+46 ;
+47 ; loop through mods in CPT array and call API to get mod code/desc
+48 SET SDI2=""
FOR
SET SDI2=$ORDER(^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CPT",SDI,SDI2))
if 'SDI2
QUIT
Begin DoDot:3
+49 NEW MODINFO,MODCODE,MODTEXT
+50 SET MODINFO=$$MOD^ICPTMOD(SDI2,"I",+SDOE0,1)
+51 if MODINFO'>0
QUIT
+52 SET MODCODE=$PIECE(MODINFO,"^",2)
+53 SET MODTEXT=$PIECE(MODINFO,"^",3)
+54 SET SDX2=MODCODE_" "_MODTEXT
+55 ; add mod code/desc to array
+56 if $LENGTH(SDX2)>1
SET ^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CPTR",SDX,SDX2)=SDI2
+57 QUIT
End DoDot:3
+58 QUIT
End DoDot:2
+59 ;Iterate through criteria combine logic
+60 ;Loop through secondary Division (SDIV) for multiple division episodes
+61 NEW SDIV
SET SDIV=""
FOR
SET SDIV=$ORDER(SDPDIV(SDIV))
if SDIV=""
QUIT
Begin DoDot:2
+62 SET SDCRI=""
FOR
SET SDCRI=$ORDER(SDCRI(SDCRI))
if SDCRI=""
QUIT
Begin DoDot:3
+63 SET SDCL=$TRANSLATE($TRANSLATE(SDCRI,"'",""),"&","")
FOR SDI=1:1:$LENGTH(SDCL)
SET SDC=$EXTRACT(SDCL,SDI)
if '$DATA(^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CRI",SDC))
Begin DoDot:4
+64 ;Build list of true items for each criteria element
+65 SET SDZ=$PIECE(SDPAR(SDC),"^")
+66 IF SDZ="DL"
SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"DX",SDI))
if 'SDI
QUIT
Begin DoDot:5
+67 if $DATA(SDPAR(SDC,SDI))
SET ^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CRI",SDC,SDI)=""
+68 QUIT
End DoDot:5
+69 IF SDZ="DR"
SET SDR1=""
SET SDR1=$ORDER(SDPAR(SDC,SDR1))
SET SDR2=$ORDER(SDPAR(SDC,SDR1))
SET SDI=""
Begin DoDot:5
+70 FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"DXR",SDI))
if SDI=""
QUIT
Begin DoDot:6
+71 IF SDR1']SDI
IF SDI']SDR2
SET ^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CRI",SDC,SDI)=""
QUIT
End DoDot:6
+72 QUIT
End DoDot:5
+73 IF SDZ="PL"
SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CPT",SDI))
if 'SDI
QUIT
Begin DoDot:5
+74 IF $DATA(SDPAR(SDC,SDI))
MERGE ^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CRI",SDC,SDI)=^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CPT",SDI)
+75 QUIT
End DoDot:5
+76 IF SDZ="PR"
SET SDR1=""
SET SDR1=$ORDER(SDPAR(SDC,SDR1))
SET SDR2=$ORDER(SDPAR(SDC,SDR1))
SET SDI=""
Begin DoDot:5
+77 FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CPTR",SDI))
if SDI=""
QUIT
Begin DoDot:6
+78 IF SDR1']SDI
IF SDI']SDR2
MERGE ^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CRI",SDC,SDI)=^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CPTR",SDI)
+79 QUIT
End DoDot:6
+80 QUIT
End DoDot:5
+81 SET ^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CRI",SDC)=($DATA(^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CRI",SDC))>0)_U_SDZ
+82 QUIT
End DoDot:4
+83 ;Apply criteria combine logic
+84 NEW A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z
+85 FOR SDI=1:1:$LENGTH(SDCL)
SET SDC=$EXTRACT(SDCL,SDI)
SET @SDC=$PIECE(^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CRI",SDC),"^")
+86 ;If combine logic is "true", move items to final list
+87 IF @SDCRI
FOR SDI=1:1:$LENGTH(SDCL)
SET SDC=$EXTRACT(SDCL,SDI)
SET SDX=^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CRI",SDC)
Begin DoDot:4
+88 IF SDX
MERGE ^TMP("SCRPW",$JOB,0,1,DFN,SDIV,$PIECE(SDX,"^",2))=^TMP("SCRPW",$JOB,0,0,DFN,SDIV,"CRI",SDC)
+89 QUIT
End DoDot:4
+90 QUIT
End DoDot:3
End DoDot:2
+91 IF '$DATA(^TMP("SCRPW",$JOB,0,1,DFN))
Begin DoDot:2
+92 SET SDIV=""
FOR
SET SDIV=$ORDER(SDPDIV(SDIV))
if SDIV=""
QUIT
KILL ^TMP("SCRPW",$JOB,SDIV,1,DFN)
+93 QUIT
End DoDot:2
QUIT
+94 ;Move item ifn lists to text lists
+95 NEW SDIV
SET SDIV=""
FOR
SET SDIV=$ORDER(SDPDIV(SDIV))
if SDIV=""
QUIT
Begin DoDot:2
+96 SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,0,1,DFN,SDIV,"DL",SDI))
if 'SDI
QUIT
Begin DoDot:3
+97 SET SDX=$$ICDDX^SCRPWICD(SDI,+SDOE0)
SET SDX=$PIECE(SDX,"^",2)_" "_$PIECE(SDX,"^",4)
if $LENGTH(SDX)>1
SET ^TMP("SCRPW",$JOB,0,1,DFN,SDIV,"DR",SDX)=$GET(SDT)
+98 QUIT
End DoDot:3
End DoDot:2
+99 NEW SDIV
SET SDIV=""
FOR
SET SDIV=$ORDER(SDPDIV(SDIV))
if SDIV=""
QUIT
Begin DoDot:2
+100 SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,0,1,DFN,SDIV,"PL",SDI))
if 'SDI
QUIT
Begin DoDot:3
+101 NEW CPTINFO,CPTCODE,CPTTEXT
+102 SET CPTINFO=$$CPT^ICPTCOD(SDI,+SDOE0,1)
+103 if CPTINFO'>0
QUIT
+104 SET CPTCODE=$PIECE(CPTINFO,"^",2)
+105 SET CPTTEXT=$PIECE(CPTINFO,"^",3)
+106 SET SDX=CPTCODE_" "_CPTTEXT
+107 if $LENGTH(SDX)>1
SET ^TMP("SCRPW",$JOB,0,1,DFN,SDIV,"PR",SDX)=""
+108 ;
+109 ;loop through mods in CPT array and call API to get mod code/desc
+110 SET SDI2=""
+111 FOR
SET SDI2=$ORDER(^TMP("SCRPW",$JOB,0,1,DFN,SDIV,"PL",SDI,SDI2))
if 'SDI2
QUIT
Begin DoDot:4
+112 NEW MODINFO,MODCODE,MODTEXT
+113 SET MODINFO=$$MOD^ICPTMOD(SDI2,"I",+SDOE0,1)
+114 if MODINFO'>0
QUIT
+115 SET MODCODE=$PIECE(MODINFO,"^",2)
+116 SET MODTEXT=$PIECE(MODINFO,"^",3)
+117 SET SDX2=MODCODE_" "_MODTEXT
+118 ; add mod code/desc to array
+119 if $LENGTH(SDX2)>1
SET ^TMP("SCRPW",$JOB,0,1,DFN,SDIV,"PR",SDX,SDX2)=""
+120 QUIT
End DoDot:4
+121 QUIT
End DoDot:3
End DoDot:2
+122 ; delete procedure list array
+123 NEW SDIV
SET SDIV=""
FOR
SET SDIV=$ORDER(SDPDIV(SDIV))
if SDIV=""
QUIT
Begin DoDot:2
+124 ;Merge activity list
+125 MERGE ^TMP("SCRPW",$JOB,SDIV,1,DFN,SDIV,"ACT")=^TMP("SCRPW",$JOB,SDIV,0,DFN,SDIV,"ACT")
+126 ;Kill scratch list, merge to summary global if multidivisional
+127 IF SDMD
IF SDFMT'="P"
MERGE ^TMP("SCRPW",$JOB,0,1,DFN,SDIV,"ACT")=^TMP("SCRPW",$JOB,SDIV,1,DFN,SDIV,"ACT")
+128 ;Delete scratch levels and arrays after merge
+129 KILL ^TMP("SCRPW",$JOB,0,1,DFN,"DL")
+130 KILL ^TMP("SCRPW",$JOB,0,1,DFN,"PL")
+131 QUIT
End DoDot:2
+132 QUIT
End DoDot:1
+133 ;Delete 0,0 scratch level prior to printing
+134 KILL ^TMP("SCRPW",$JOB,0,0)
+135 if SDOUT
GOTO EXIT^SCRPW47
GOTO ^SCRPW47
+136 ;
DIV() ;Check division
+1 if 'SDDIV
QUIT 1
QUIT $DATA(SDDIV(+SDIV))
