RTNQ3 ;MJK/TROY ISC;Combined Data Trace; ; 5/20/87 4:35 PM ;
;;v 2.0;Record Tracking;;10/22/91
I '$D(RTAPL) D APL2^RTPSET D NEXT:$D(RTAPL) K RTAPL,RTSYS Q
NEXT D PT^RTUTL3 G Q:Y<0
S %DT="AEPX",%DT(0)="-NOW",%DT("B")="T-100",%DT("A")="Trace Cut-off Date: " D ^%DT K %DT G Q:Y<0 S RTDT=Y-.0001
S RTPGM="START^RTNQ3",RTVAR="RTE^RTDT^DFN^RTAPL" D ZIS^RTUTL G Q:POP D START G NEXT
;
START U IO S RTESC="",RTPAGE=0 K R,^TMP($J,"RTCOMBO") S R="" I '$D(IOSL)!('$D(IOF)) S IOP="" D ^%ZIS K IOP
S A=+RTAPL F RT=0:0 S RT=$O(^RT("AA",A,RTE,RT)) Q:'RT I $D(^RT(RT,0)) S Y=^(0) D REC F RTH=0:0 S RTH=$O(^RTV(190.3,"B",RT,RTH)) Q:'RTH I $D(^RTV(190.3,RTH,0)) S Y=^(0) D HIS:$P(Y,"^",6)'<RTDT
F S=RTDT:0 S S=$O(^DPT(DFN,"S",S)) Q:'S I $D(^(S,0)),$P(^(0),U,2)'["C" S D=9999999.9999-S,Y=$E($S($D(^SC(+^(0),0)):$P(^(0),"^"),1:"UNKNOWN"),1,19),P=2 D SET
S RTDTI=9999999.9999-RTDT
F A=0:0 S A=$O(^DGPM("APID",DFN,A)) Q:'A!(A>RTDTI) S DGPMDA=+$O(^(A,0)) I $D(^DGPM(DGPMDA,0)) S Y=^(0),TT=$P(Y,"^",2) I TT,TT<4 D DIS:TT=3,MVT
D HD I $D(R)<11,'$D(^TMP($J,"RTCOMBO")) W !!?5,"No activity for period." G Q
K RTFL S RTFUT=1,RTG="S RTI=$O("_$S($D(R):"R(RTI)",1:"^TMP($J,""RTCOMBO"",RTI)")_")"
S RTG1="S RTI1=$O("_$S($D(R):"R(RTI,RTI1)",1:"^TMP($J,""RTCOMBO"",RTI,RTI1)")_")"
F RTI=0:0 X RTG Q:'RTI F RTI1=0:0 X RTG1 Q:'RTI1 D LIST G Q:RTESC="^"
Q K RTFUT,RTPAGE,RTESC,RTE,RTFL,RTDTI,A1,A,S,RTVAR,RTPGM,RTDT,R,RT,M,P,DFN,RTG,RTH,RTI,T,V,^TMP($J,"RTCOMBO") D CLOSE^RTUTL
K DUOUT,C,I,X,Y,RTG1,%,%H,%I,N,POP,RTI1,DGPMDA,TT Q
LIST ;
D HD:($Y+5)>IOSL Q:RTESC="^" S Y=$E(9999999.9999-RTI,1,12) D FUT:$P(Y,".")'>DT&(RTFUT),D^DIQ S D=Y,RTFL="",Y=$S($D(R):R(RTI,RTI1),1:^TMP($J,"RTCOMBO",RTI,RTI1)) W !,D,?20,$P(Y,"^"),?40,$P(Y,"^",2),?60,$P(Y,"^",3) Q
SET D DUMP:$S<2000 I $D(R) F I=1:1 S:'$D(R(D,I)) R(D,I)="" I $P(R(D,I),"^",P)="" S $P(R(D,I),"^",P)=Y Q
Q:$D(R) F I=1:1 S:'$D(^TMP($J,"RTCOMBO",D,I)) ^TMP($J,"RTCOMBO",D,I)="" I $P(^TMP($J,"RTCOMBO",D,I),"^",P)="" S $P(^TMP($J,"RTCOMBO",D,I),"^",P)=Y Q
Q
;
REC S V=$S('$D(^DIC(195.2,+$P(Y,"^",3),0)):"UNKNOWN",1:$P(^(0),"^",2))_+$P(Y,"^",7) Q
;
HIS S D=9999999.9999-$P(Y,"^",6),Y=$P(Y,"^",5) D BOR^RTB S Y=Y_" ",Y=$E(Y,1,14)_";"_V,P=1 D SET Q
;
MVT ; -- set up vars for mvt entry ; Y = 0th node of mvt
I TT=2,$P(Y,"^",18)'=4 G MVTQ ; must be interward tfr
S D=9999999.9999-Y
S Y=$S($D(^DIC(42,+$P(Y,"^",6),0)):$P(^(0),"^"),1:"UNKNOWN")_" "
S Y=$E(Y,1,14)_";"_$P("adm^tfr^dis","^",TT),P=3 D SET
MVTQ K D Q
;
DIS ; -- find last ward before d/c ; Y = 0th node of mvt
S CA=$P(Y,"^",14)
F IDT=0:0 S IDT=$O(^DGPM("APMV",DFN,CA,IDT)) Q:'IDT F MVT=0:0 S MVT=$O(^DGPM("APMV",DFN,CA,IDT,MVT)) Q:'MVT I $D(^DGPM(MVT,0)),$P(^(0),"^",6) S $P(Y,"^",6)=$P(^(0),"^",6) G DISQ
DISQ K CA,MVT,IDT Q
;
HD S RTESC="" I RTPAGE,IOST["C-" R !!,"Press RETURN to continue or '^' to stop: ",RTESC:DTIME S:'$T RTESC="^" Q:RTESC["^"
S RTPAGE=RTPAGE+1,X1="ADT,Scheduling and Tracking Data Trace Report ("_$P($P(RTAPL,"^"),";",2)_")" D PTHD^RTUTL2,EQUALS^RTUTL3
S Y=RTDT+.0001 D D^DIQ W !,"[Report compiled with data on activities back to ",Y,"]"
W !,"Date/Time",?20,"Record Location",?40,"Clinic Name",?60,"Ward;Action" D LINE^RTUTL3
Q
;
DUMP F I=0:0 S I=$O(R(I)) Q:'I F I1=0:0 S I1=$O(R(I,I1)) Q:'I1 S ^TMP($J,"RTCOMBO",I,I1)=R(I,I1)
K R Q
;
FUT S RTFUT=0 Q:'$D(RTFL) D EQUALS^RTUTL3 W !?20,"ABOVE THIS LINE ARE 'FUTURE' ACTIVITIES" D EQUALS^RTUTL3 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTNQ3 3465 printed Dec 13, 2024@02:34:07 Page 2
RTNQ3 ;MJK/TROY ISC;Combined Data Trace; ; 5/20/87 4:35 PM ;
+1 ;;v 2.0;Record Tracking;;10/22/91
+2 IF '$DATA(RTAPL)
DO APL2^RTPSET
if $DATA(RTAPL)
DO NEXT
KILL RTAPL,RTSYS
QUIT
NEXT DO PT^RTUTL3
if Y<0
GOTO Q
+1 SET %DT="AEPX"
SET %DT(0)="-NOW"
SET %DT("B")="T-100"
SET %DT("A")="Trace Cut-off Date: "
DO ^%DT
KILL %DT
if Y<0
GOTO Q
SET RTDT=Y-.0001
+2 SET RTPGM="START^RTNQ3"
SET RTVAR="RTE^RTDT^DFN^RTAPL"
DO ZIS^RTUTL
if POP
GOTO Q
DO START
GOTO NEXT
+3 ;
START USE IO
SET RTESC=""
SET RTPAGE=0
KILL R,^TMP($JOB,"RTCOMBO")
SET R=""
IF '$DATA(IOSL)!('$DATA(IOF))
SET IOP=""
DO ^%ZIS
KILL IOP
+1 SET A=+RTAPL
FOR RT=0:0
SET RT=$ORDER(^RT("AA",A,RTE,RT))
if 'RT
QUIT
IF $DATA(^RT(RT,0))
SET Y=^(0)
DO REC
FOR RTH=0:0
SET RTH=$ORDER(^RTV(190.3,"B",RT,RTH))
if 'RTH
QUIT
IF $DATA(^RTV(190.3,RTH,0))
SET Y=^(0)
if $PIECE(Y,"^",6)'<RTDT
DO HIS
+2 FOR S=RTDT:0
SET S=$ORDER(^DPT(DFN,"S",S))
if 'S
QUIT
IF $DATA(^(S,0))
IF $PIECE(^(0),U,2)'["C"
SET D=9999999.9999-S
SET Y=$EXTRACT($SELECT($DATA(^SC(+^(0),0)):$PIECE(^(0),"^"),1:"UNKNOWN"),1,19)
SET P=2
DO SET
+3 SET RTDTI=9999999.9999-RTDT
+4 FOR A=0:0
SET A=$ORDER(^DGPM("APID",DFN,A))
if 'A!(A>RTDTI)
QUIT
SET DGPMDA=+$ORDER(^(A,0))
IF $DATA(^DGPM(DGPMDA,0))
SET Y=^(0)
SET TT=$PIECE(Y,"^",2)
IF TT
IF TT<4
if TT=3
DO DIS
DO MVT
+5 DO HD
IF $DATA(R)<11
IF '$DATA(^TMP($JOB,"RTCOMBO"))
WRITE !!?5,"No activity for period."
GOTO Q
+6 KILL RTFL
SET RTFUT=1
SET RTG="S RTI=$O("_$SELECT($DATA(R):"R(RTI)",1:"^TMP($J,""RTCOMBO"",RTI)")_")"
+7 SET RTG1="S RTI1=$O("_$SELECT($DATA(R):"R(RTI,RTI1)",1:"^TMP($J,""RTCOMBO"",RTI,RTI1)")_")"
+8 FOR RTI=0:0
XECUTE RTG
if 'RTI
QUIT
FOR RTI1=0:0
XECUTE RTG1
if 'RTI1
QUIT
DO LIST
if RTESC="^"
GOTO Q
Q KILL RTFUT,RTPAGE,RTESC,RTE,RTFL,RTDTI,A1,A,S,RTVAR,RTPGM,RTDT,R,RT,M,P,DFN,RTG,RTH,RTI,T,V,^TMP($JOB,"RTCOMBO")
DO CLOSE^RTUTL
+1 KILL DUOUT,C,I,X,Y,RTG1,%,%H,%I,N,POP,RTI1,DGPMDA,TT
QUIT
LIST ;
+1 if ($Y+5)>IOSL
DO HD
if RTESC="^"
QUIT
SET Y=$EXTRACT(9999999.9999-RTI,1,12)
if $PIECE(Y,".")'>DT&(RTFUT)
DO FUT
DO D^DIQ
SET D=Y
SET RTFL=""
SET Y=$SELECT($DATA(R):R(RTI,RTI1),1:^TMP($JOB,"RTCOMBO",RTI,RTI1))
WRITE !,D,?20,$PIECE(Y,"^"),?40,$PIECE(Y,"^",2),?60,$PIECE(Y,"^",3)
QUIT
SET if $STORAGE<2000
DO DUMP
IF $DATA(R)
FOR I=1:1
if '$DATA(R(D,I))
SET R(D,I)=""
IF $PIECE(R(D,I),"^",P)=""
SET $PIECE(R(D,I),"^",P)=Y
QUIT
+1 if $DATA(R)
QUIT
FOR I=1:1
if '$DATA(^TMP($JOB,"RTCOMBO",D,I))
SET ^TMP($JOB,"RTCOMBO",D,I)=""
IF $PIECE(^TMP($JOB,"RTCOMBO",D,I),"^",P)=""
SET $PIECE(^TMP($JOB,"RTCOMBO",D,I),"^",P)=Y
QUIT
+2 QUIT
+3 ;
REC SET V=$SELECT('$DATA(^DIC(195.2,+$PIECE(Y,"^",3),0)):"UNKNOWN",1:$PIECE(^(0),"^",2))_+$PIECE(Y,"^",7)
QUIT
+1 ;
HIS SET D=9999999.9999-$PIECE(Y,"^",6)
SET Y=$PIECE(Y,"^",5)
DO BOR^RTB
SET Y=Y_" "
SET Y=$EXTRACT(Y,1,14)_";"_V
SET P=1
DO SET
QUIT
+1 ;
MVT ; -- set up vars for mvt entry ; Y = 0th node of mvt
+1 ; must be interward tfr
IF TT=2
IF $PIECE(Y,"^",18)'=4
GOTO MVTQ
+2 SET D=9999999.9999-Y
+3 SET Y=$SELECT($DATA(^DIC(42,+$PIECE(Y,"^",6),0)):$PIECE(^(0),"^"),1:"UNKNOWN")_" "
+4 SET Y=$EXTRACT(Y,1,14)_";"_$PIECE("adm^tfr^dis","^",TT)
SET P=3
DO SET
MVTQ KILL D
QUIT
+1 ;
DIS ; -- find last ward before d/c ; Y = 0th node of mvt
+1 SET CA=$PIECE(Y,"^",14)
+2 FOR IDT=0:0
SET IDT=$ORDER(^DGPM("APMV",DFN,CA,IDT))
if 'IDT
QUIT
FOR MVT=0:0
SET MVT=$ORDER(^DGPM("APMV",DFN,CA,IDT,MVT))
if 'MVT
QUIT
IF $DATA(^DGPM(MVT,0))
IF $PIECE(^(0),"^",6)
SET $PIECE(Y,"^",6)=$PIECE(^(0),"^",6)
GOTO DISQ
DISQ KILL CA,MVT,IDT
QUIT
+1 ;
HD SET RTESC=""
IF RTPAGE
IF IOST["C-"
READ !!,"Press RETURN to continue or '^' to stop: ",RTESC:DTIME
if '$TEST
SET RTESC="^"
if RTESC["^"
QUIT
+1 SET RTPAGE=RTPAGE+1
SET X1="ADT,Scheduling and Tracking Data Trace Report ("_$PIECE($PIECE(RTAPL,"^"),";",2)_")"
DO PTHD^RTUTL2
DO EQUALS^RTUTL3
+2 SET Y=RTDT+.0001
DO D^DIQ
WRITE !,"[Report compiled with data on activities back to ",Y,"]"
+3 WRITE !,"Date/Time",?20,"Record Location",?40,"Clinic Name",?60,"Ward;Action"
DO LINE^RTUTL3
+4 QUIT
+5 ;
DUMP FOR I=0:0
SET I=$ORDER(R(I))
if 'I
QUIT
FOR I1=0:0
SET I1=$ORDER(R(I,I1))
if 'I1
QUIT
SET ^TMP($JOB,"RTCOMBO",I,I1)=R(I,I1)
+1 KILL R
QUIT
+2 ;
FUT SET RTFUT=0
if '$DATA(RTFL)
QUIT
DO EQUALS^RTUTL3
WRITE !?20,"ABOVE THIS LINE ARE 'FUTURE' ACTIVITIES"
DO EQUALS^RTUTL3
QUIT
