142 lines
7.8 KiB
Mathematica
142 lines
7.8 KiB
Mathematica
|
SCRPW26 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 18 Nov 98 3:31 PM
|
||
|
|
;;5.3;Scheduling;**144,166,370,461**;AUG 13, 1993
|
||
|
|
RPT I '$D(ZTQUEUED),$E(IOST)="C" D WAIT^DICD
|
||
|
|
D BLD^SCRPW21 S SDXY=^%ZOSF("XY")
|
||
|
|
F SDI="DSV","M1","MASTER","TOT","RPT","DET","RPTAP","RPTDX","RPTTAP","RPTTDX" K ^TMP("SCRPW",$J,SDI)
|
||
|
|
S T="~",(SDSTOP,SDOUT)=0,SDT=$P(SDPAR("L",1),U),SDO(1)=$P(SDPAR("O",1),U) F SDI=1:1:6 S SDF(SDI)=$P($G(SDPAR("F",SDI)),U)
|
||
|
|
S SDI=2 F S SDI=$O(SDPAR("L",SDI)) Q:'SDI S SDX=$P(SDPAR("L",SDI),U)_$P(SDPAR("L",SDI,1),U),SDPAR("LPX",SDX,SDI)=""
|
||
|
|
S SDYR=1,SDEDT=$P(SDPAR("L",2),U)+.999999 D R0 G:SDOUT RX
|
||
|
|
I SDF(2) S SDT=$P(SDPAR("L",1),U)-10000,SDEDT=SDEDT-10000,SDYR=2 D R0 G:SDOUT RX
|
||
|
|
I SDF(5)>0 D R6 G:SDOUT RX
|
||
|
|
F SDI="TOT","RPT" Q:SDOUT D R7,STOP
|
||
|
|
G:SDOUT RX D R8,STOP G:SDOUT RX G PRT^SCRPW27
|
||
|
|
;
|
||
|
|
RX G EXIT^SCRPW27
|
||
|
|
;
|
||
|
|
STOP ;Check for stop task request
|
||
|
|
S:$D(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
|
||
|
|
;
|
||
|
|
R0 F S SDT=$O(^SCE("B",SDT)) Q:'SDT!(SDT>SDEDT)!SDOUT S SDOE=0 F S SDOE=$O(^SCE("B",SDT,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE) I $P(SDOE0,U,2),$P(SDOE0,U,4),'$P(SDOE0,U,6) D R1
|
||
|
|
Q
|
||
|
|
R1 ;Evaluate perspective
|
||
|
|
S SDSTOP=SDSTOP+1 D:SDSTOP#3000=0 STOP Q:SDOUT
|
||
|
|
;CHECK FOR TEST PATIENT
|
||
|
|
I $D(^DPT("ATEST",$P(SDOE0,U,2))) Q
|
||
|
|
K SDPER Q:'$$EVAL("P",1) M SDPER=SDX
|
||
|
|
R2 ;Evaluate limitations
|
||
|
|
; SD*5.3*461 following code replaces original code
|
||
|
|
N SDXPAR,SDNN,SDFLAG,SDSAVE
|
||
|
|
S SDXPAR="",SDNN=2,SDFLAG=1,SDSAVE=0
|
||
|
|
I $O(SDPAR("L",SDNN)) S SDNN=$O(SDPAR("L",SDNN)),SDXPAR=$G(SDPAR("L",SDNN))
|
||
|
|
S SDFOUND=1,SDS2=2 F S SDS2=$O(SDPAR("L",SDS2)) Q:'SDS2 D
|
||
|
|
. I $D(SDXPAR) S:SDXPAR'=$G(SDPAR("L",SDS2)) SDFLAG=0
|
||
|
|
. S:SDFLAG SDFOUND=1
|
||
|
|
. S:'$$EVAL("L",SDS2) SDFOUND=0
|
||
|
|
. I SDFOUND I SDFLAG S SDSAVE=1
|
||
|
|
. I 'SDFLAG I 'SDFOUND S SDSAVE=0
|
||
|
|
S:SDSAVE SDFOUND=SDSAVE
|
||
|
|
Q:'SDFOUND S (SDTOT,SDI)=0 F S SDI=$O(SDPER(SDI)) Q:'SDI S SDPER=SDPER(SDI) S:$G(SDPAR("P",1,6))="D" SDPER=$P(SDPER,U,2)_U_$P(SDPER,U) D R3
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
R3 S DFN=$P(SDOE0,U,2)
|
||
|
|
S:'SDTOT ^TMP("SCRPW",$J,"TOT",SDYR,1,1,DFN,$P(SDT,"."))="",^TMP("SCRPW",$J,"TOT",SDYR,1,1,"ENC")=$G(^TMP("SCRPW",$J,"TOT",SDYR,1,1,"ENC"))+1,SDTOT=1
|
||
|
|
S ^TMP("SCRPW",$J,"M1",$P(SDPER,U,2),$P(SDPER,U))=""
|
||
|
|
S ^TMP("SCRPW",$J,"RPT",SDYR,$P(SDPER,U,2),$P(SDPER,U),DFN,$P(SDT,"."))="",^TMP("SCRPW",$J,"RPT",SDYR,$P(SDPER,U,2),$P(SDPER,U),"ENC")=$G(^TMP("SCRPW",$J,"RPT",SDYR,$P(SDPER,U,2),$P(SDPER,U),"ENC"))+1
|
||
|
|
I $L(SDF(3)),"EB"[SDF(3) S SDPNAM=$P($G(^DPT(DFN,0)),U) I $L(SDPNAM) S ^TMP("SCRPW",$J,"DET",$$DSV(SDPER),SDPNAM,DFN,$P(SDT,"."),SDT,SDOE)=$P(SDOE0,U,4)
|
||
|
|
Q:(SDF(5)<1)!(SDYR=2)
|
||
|
|
D APAC^SCRPW24(.SDX) S SDII=0 F S SDII=$O(SDX(SDII)) Q:'SDII D R4
|
||
|
|
D DXPD^SCRPW24(.SDX) S SDII=0 F S SDII=$O(SDX(SDII)) Q:'SDII D R5(1)
|
||
|
|
D DXSD^SCRPW24(.SDX) S SDII=0 F S SDII=$O(SDX(SDII)) Q:'SDII D R5(2)
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
R4 S SDX=SDX(SDII) Q:$P(SDX,U)="~~~NONE~~~" S SDQT=$P(SDX,U,3) S:'SDQT SDQT=1
|
||
|
|
S ^TMP("SCRPW",$J,"RPTAP",SDYR,$P(SDPER,U,2),$P(SDPER,U),$P(SDX,U,2))=$G(^TMP("SCRPW",$J,"RPTAP",SDYR,$P(SDPER,U,2),$P(SDPER,U),$P(SDX,U,2)))+SDQT Q
|
||
|
|
;
|
||
|
|
R5(SDZ) S SDX=SDX(SDII) Q:$P(SDX,U)="~~~NONE~~~"
|
||
|
|
F SDIII=SDZ,3 S $P(^TMP("SCRPW",$J,"RPTDX",SDYR,$P(SDPER,U,2),$P(SDPER,U),$P(SDX,U,2)),U,SDIII)=$P($G(^TMP("SCRPW",$J,"RPTDX",SDYR,$P(SDPER,U,2),$P(SDPER,U),$P(SDX,U,2))),U,SDIII)+1
|
||
|
|
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
|
||
|
|
;
|
||
|
|
R6 S SDS1="" F S SDS1=$O(^TMP("SCRPW",$J,"RPTAP",SDS1)) Q:SDS1="" S SDS2="" F S SDS2=$O(^TMP("SCRPW",$J,"RPTAP",SDS1,SDS2)) Q:SDS2="" D R6A
|
||
|
|
D STOP Q:SDOUT
|
||
|
|
S SDS1="" F S SDS1=$O(^TMP("SCRPW",$J,"RPTDX",SDS1)) Q:SDS1="" S SDS2="" F S SDS2=$O(^TMP("SCRPW",$J,"RPTDX",SDS1,SDS2)) Q:SDS2="" D R6B
|
||
|
|
D STOP Q
|
||
|
|
;
|
||
|
|
R6A S SDS3="" F S SDS3=$O(^TMP("SCRPW",$J,"RPTAP",SDS1,SDS2,SDS3)) Q:SDS3="" S SDS4="" F S SDS4=$O(^TMP("SCRPW",$J,"RPTAP",SDS1,SDS2,SDS3,SDS4)) Q:SDS4="" D R6AS
|
||
|
|
Q
|
||
|
|
R6AS S SDQT=^TMP("SCRPW",$J,"RPTAP",SDS1,SDS2,SDS3,SDS4),^TMP("SCRPW",$J,"RPTTAP",SDS1,SDS2,SDS3,SDQT,SDS4)=""
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
R6B S SDS3="" F S SDS3=$O(^TMP("SCRPW",$J,"RPTDX",SDS1,SDS2,SDS3)) Q:SDS3="" S SDS4="" F S SDS4=$O(^TMP("SCRPW",$J,"RPTDX",SDS1,SDS2,SDS3,SDS4)) Q:SDS4="" D R6BS
|
||
|
|
Q
|
||
|
|
R6BS S SDQT=$P(^TMP("SCRPW",$J,"RPTDX",SDS1,SDS2,SDS3,SDS4),U,3),^TMP("SCRPW",$J,"RPTTDX",SDS1,SDS2,SDS3,SDQT,SDS4)=""
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
R7 S SDYR=0 F S SDYR=$O(^TMP("SCRPW",$J,SDI,SDYR)) Q:'SDYR S SDS1="" F S SDS1=$O(^TMP("SCRPW",$J,SDI,SDYR,SDS1)) Q:SDS1="" S SDS2="" F S SDS2=$O(^TMP("SCRPW",$J,SDI,SDYR,SDS1,SDS2)) Q:SDS2="" D R7A
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
R7A S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDI,SDYR,SDS1,SDS2,DFN)) Q:'DFN S ^TMP("SCRPW",$J,SDI,SDYR,SDS1,SDS2,"UNI")=$G(^TMP("SCRPW",$J,SDI,SDYR,SDS1,SDS2,"UNI"))+1 D R7B
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
R7B S SDT=0 F S SDT=$O(^TMP("SCRPW",$J,SDI,SDYR,SDS1,SDS2,DFN,SDT)) Q:'SDT S ^TMP("SCRPW",$J,SDI,SDYR,SDS1,SDS2,"VIS")=$G(^TMP("SCRPW",$J,SDI,SDYR,SDS1,SDS2,"VIS"))+1
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
R8 S SDORD=$E($P(SDPAR("O",1),U,2),1,3),SDS1="" F S SDS1=$O(^TMP("SCRPW",$J,"M1",SDS1)) Q:SDS1="" S SDS2="" F S SDS2=$O(^TMP("SCRPW",$J,"M1",SDS1,SDS2)) Q:SDS2="" D R8A
|
||
|
|
Q
|
||
|
|
R8A S SDORDV=$S(SDORD="ALP":SDS1,1:+$G(^TMP("SCRPW",$J,"RPT",1,SDS1,SDS2,SDORD))),^TMP("SCRPW",$J,"MASTER",SDORDV,SDS1,SDS2)="" Q
|
||
|
|
;
|
||
|
|
EVAL(SDS1,SDS2) ;Evaluate item
|
||
|
|
D GID(SDS1,SDS2) K SDX X $P(SD(1),T,7)
|
||
|
|
I SDS1="P",SDF(1)="S" D EVIL Q $D(SDX)>1
|
||
|
|
D EV0(SDS1,SDS2) D:SDS1="P" EVIL
|
||
|
|
Q $D(SDX)>1
|
||
|
|
;
|
||
|
|
EV0(SDS1,SDS2) N X,Y,SDR1,SDR2,SDZ S SDZ=SD(3)="E",SDI=0 F S SDI=$O(SDX(SDI)) Q:'SDI S X=$P(SDX(SDI),U) D EV1
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
EV1 I "LN"[SD(2) K:('SDZ&'$D(SDPAR(SDS1,SDS2,5,X))) SDX(SDI) K:(SDZ&$D(SDPAR(SDS1,SDS2,5,X))) SDX Q
|
||
|
|
S Y=$S(SD(6)="D":1,+$P(SDX(SDI),U,2)=$P(SDX(SDI),U,2):1,1:0),SDR1=$O(SDPAR(SDS1,SDS2,(4+Y),"")),SDR2=$O(SDPAR(SDS1,SDS2,(4+Y),""),-1)
|
||
|
|
I Y S:(SD(6)="D"&(SDR2#1=0)) SDR2=SDR2+.9999 K:('SDZ&(X<SDR1!(X>SDR2))) SDX(SDI) K:(SDZ&(X'<SDR1&(X'>SDR2))) SDX Q
|
||
|
|
I S0="DXAD" S X=$P(SDX(SDI),U,2) D DXRNGE Q ;SD*5.3*461
|
||
|
|
S X=$P(SDX(SDI),U,2) K:('SDZ&(SDR1]X!(X]SDR2))) SDX(SDI) K:(SDZ&(SDR1']X&(X']SDR2))) SDX Q
|
||
|
|
;
|
||
|
|
EVIL ;Evaluate item limitations
|
||
|
|
N SDS2 I $D(SDX)>1 S S1=SD(0),S2=$P(SD(1),T,10) F S0=S1,S2 I $L(S0) S SDS2=0 F S SDS2=$O(SDPAR("LPX",S0,SDS2)) Q:'SDS2 D GID("L",SDS2),EV0("L",SDS2)
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
GID(SDS1,SDS2) ;Get item data
|
||
|
|
;Required input: SDS1,SDS2=subscript values in SDPAR array.
|
||
|
|
K SD
|
||
|
|
S SD(0)=$P(SDPAR(SDS1,SDS2),U)_$P(SDPAR(SDS1,SDS2,1),U),SD(1)=^TMP("SCRPW",$J,"ACT",SD(0))
|
||
|
|
F SDI=2,3,6 S SD(SDI)=$P($G(SDPAR(SDS1,SDS2,SDI)),U)
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
DXRNGE ; added per SD*5.3*461
|
||
|
|
N SDFLG1
|
||
|
|
S SDFLG1=0
|
||
|
|
S SDS22=2
|
||
|
|
F S SDS22=$O(SDPAR(SDS1,SDS22)) Q:'SDS22 D
|
||
|
|
.S SDR1=$O(SDPAR(SDS1,SDS22,(4+Y),"")),SDR2=$O(SDPAR(SDS1,SDS22,(4+Y),""),-1)
|
||
|
|
.I ('SDZ&(SDR1']X&(X']SDR2))) S SDFLG1=1
|
||
|
|
K:'SDFLG1 SDX(SDI)
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
TEST K DIC,DIR D BLD^SCRPW21 S DIC="^SCE(",DIC(0)="AEMQZ" D ^DIC Q:$D(DTOUT)!$D(DUOUT) Q:'Y S SDOE=+Y,SDOE0=Y(0),T="~",DIR(0)="E"
|
||
|
|
S SDI="" F S SDI=$O(^TMP("SCRPW",$J,"ACT",SDI)) Q:SDI="" S SDA=^TMP("SCRPW",$J,"ACT",SDI) W !!,$P(SDA,T) D TEST1 W ! ;D ^DIR Q:'Y
|
||
|
|
D R1
|
||
|
|
Q
|
||
|
|
TEST1 X $P(SDA,T,7) S SDII="" F S SDII=$O(SDX(SDII)) Q:'SDII W !?5,SDX(SDII)
|
||
|
|
Q
|
||
|
|
;
|
||
|
|
INTRO ;Intro. text
|
||
|
|
W !!?10,"This report can be used to produce information from the ACRP",!?10,"databases in a variety of ways. Parameter selection will",!?10,"determine how to count and screen the information."
|
||
|
|
W !!?10,"The report user is prompted for report parameters in the",!?10,"following categories:",!!?10,$$XY^SCRPW20(IORVON),"FORMAT",$$XY^SCRPW20(IORVOFF)," - determines the style of report to be printed."
|
||
|
|
W !!?10,$$XY^SCRPW20(IORVON),"PERSPECTIVE",$$XY^SCRPW20(IORVOFF)," - the element that the report will be organized",!?10,"and sub-totaled by."
|
||
|
|
W !!?10,$$XY^SCRPW20(IORVON),"LIMITATIONS",$$XY^SCRPW20(IORVOFF)," - elements that can be used to narrow the scope"
|
||
|
|
W !?10,"of the report to only include (or exclude) specified data.",!!?10,$$XY^SCRPW20(IORVON),"OUTPUT ORDER, PRINT FIELDS",$$XY^SCRPW20(IORVOFF)," - determines the order of output;"
|
||
|
|
W !?10,"allows selection of print fields for detailed patient lists." Q
|