- 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 Feb 19, 2025@00:00:38 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