RTNQ41 ;MJK,PKE/TROY ISC;Expanded Record Inquiry cont; ; 9/4/90 9:57 AM ;
;;v 2.0;Record Tracking;**19,20,21**;10/22/91
S DFN=+RTE,(R3,R2)=""
;appointment
S (I,S)=0
F S S=$O(^DPT(DFN,"S",S)) Q:'S DO
.I $P(^DPT(DFN,"S",S,0),U,2)'["C" DO
..S I=I+1,Z(I)=S
..K Z(I-3)
N RTLPCT
S CT=0,RTLPCT=$O(Z(0))
I RTLPCT DO
.F S=RTLPCT:1:RTLPCT+2 DO
..I $D(Z(S)),($D(^DPT(DFN,"S",Z(S),0))) DO
...S Y=Z(S) D D^DIQ
...S Y=$E($S($D(^SC(+^(0),0)):$P(^(0),"^"),1:"UNKNOWN"),1,19)_"^"_Y
...S CT=CT+1
...S R3(4-CT)=Y
K RTLPCT
;admissions
D ADM^VADPT2 S Y=VADMVT
I +Y S CT=4,Y=^DGPM(VADMVT,0),M="adm" D ADM S M="dis",CT=5 D DIS Q
I Y="" S M="dis",CT=5 K RTAD D DIS Q:'$D(RTAD) S M="adm",Y=^DGPM(RTAD,0),CT=4 D ADM Q
Q
Q K RTFUT,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 RTG1,%,%H,%I,N,POP,RTI1 Q
;
REC S V=$S('$D(^DIC(195.2,+$P(Y,"^",3),0)):"UNKNOWN",1:$P(^(0),"^",2))_+$P(Y,"^",7) Q
;
ADM ;
S D1=+Y,D=9999999.9999-Y,Y=$S($D(^DIC(42,+$P(Y,"^",6),0)):$P(^(0),"^"),1:"UNKNOWN")_" ",R2(CT)=$E(Y,1,20)_";"_M,Y=$E(D1,1,12) D D^DIQ S R2(CT)=R2(CT)_"^"_Y
Q
DIS ;
Q:'$D(^DGPM("ATID3",DFN)) D NOW^%DTC S Y=$O(^DGPM("ATID3",DFN,9999999.9999999-%)) Q:Y="" S Y=$O(^(Y,0)),DA=Y,Y=^DGPM(Y,0),RTY=Y,RTAD=$S($P(Y,U,14):$P(Y,U,14),1:0)
S DIC="^DGPM(",DR=200,DIQ(0)="E",DIQ="HLD($J," D EN^DIQ1 K DIC,DR S X=$S($D(HLD($J,405,DA,200,"E")):HLD($J,405,DA,200,"E"),1:0),X=X_" ",Y=RTY,R2(CT)=$E(X,1,20)_";"_M,Y=+Y D D^DIQ S R2(CT)=R2(CT)_"^"_Y
K RTY,HLD($J,405,DA),DA
Q
;
DPL ;Displays the admissions and discharges.
D LINE^RTUTL3
F CT=1:1:3 I $D(R3(CT)) W !,$P($T(LABELS+CT),";;",2)," ",$E($P(R3(CT),"^")_" ",1,20),$P(R3(CT),"^",2)
XXX F CT=4:1:5 I $D(R2(CT)) W !,$P($T(LABELS+CT),";;",2)," ",$E($P(R2(CT),"^")_" ",1,20),$P(R2(CT),"^",2)
Q
LABELS ;;
;;Clinic appoint :
;;Clinic appoint :
;;Clinic appoint :
;;Last Admission :
;;Last Discharge :
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTNQ41 2039 printed Sep 23, 2025@20:10:30 Page 2
RTNQ41 ;MJK,PKE/TROY ISC;Expanded Record Inquiry cont; ; 9/4/90 9:57 AM ;
+1 ;;v 2.0;Record Tracking;**19,20,21**;10/22/91
+2 SET DFN=+RTE
SET (R3,R2)=""
+3 ;appointment
+4 SET (I,S)=0
+5 FOR
SET S=$ORDER(^DPT(DFN,"S",S))
if 'S
QUIT
Begin DoDot:1
+6 IF $PIECE(^DPT(DFN,"S",S,0),U,2)'["C"
Begin DoDot:2
+7 SET I=I+1
SET Z(I)=S
+8 KILL Z(I-3)
End DoDot:2
End DoDot:1
+9 NEW RTLPCT
+10 SET CT=0
SET RTLPCT=$ORDER(Z(0))
+11 IF RTLPCT
Begin DoDot:1
+12 FOR S=RTLPCT:1:RTLPCT+2
Begin DoDot:2
+13 IF $DATA(Z(S))
IF ($DATA(^DPT(DFN,"S",Z(S),0)))
Begin DoDot:3
+14 SET Y=Z(S)
DO D^DIQ
+15 SET Y=$EXTRACT($SELECT($DATA(^SC(+^(0),0)):$PIECE(^(0),"^"),1:"UNKNOWN"),1,19)_"^"_Y
+16 SET CT=CT+1
+17 SET R3(4-CT)=Y
End DoDot:3
End DoDot:2
End DoDot:1
+18 KILL RTLPCT
+19 ;admissions
+20 DO ADM^VADPT2
SET Y=VADMVT
+21 IF +Y
SET CT=4
SET Y=^DGPM(VADMVT,0)
SET M="adm"
DO ADM
SET M="dis"
SET CT=5
DO DIS
QUIT
+22 IF Y=""
SET M="dis"
SET CT=5
KILL RTAD
DO DIS
if '$DATA(RTAD)
QUIT
SET M="adm"
SET Y=^DGPM(RTAD,0)
SET CT=4
DO ADM
QUIT
+23 QUIT
Q KILL RTFUT,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 RTG1,%,%H,%I,N,POP,RTI1
QUIT
+2 ;
REC SET V=$SELECT('$DATA(^DIC(195.2,+$PIECE(Y,"^",3),0)):"UNKNOWN",1:$PIECE(^(0),"^",2))_+$PIECE(Y,"^",7)
QUIT
+1 ;
ADM ;
+1 SET D1=+Y
SET D=9999999.9999-Y
SET Y=$SELECT($DATA(^DIC(42,+$PIECE(Y,"^",6),0)):$PIECE(^(0),"^"),1:"UNKNOWN")_" "
SET R2(CT)=$EXTRACT(Y,1,20)_";"_M
SET Y=$EXTRACT(D1,1,12)
DO D^DIQ
SET R2(CT)=R2(CT)_"^"_Y
+2 QUIT
DIS ;
+1 if '$DATA(^DGPM("ATID3",DFN))
QUIT
DO NOW^%DTC
SET Y=$ORDER(^DGPM("ATID3",DFN,9999999.9999999-%))
if Y=""
QUIT
SET Y=$ORDER(^(Y,0))
SET DA=Y
SET Y=^DGPM(Y,0)
SET RTY=Y
SET RTAD=$SELECT($PIECE(Y,U,14):$PIECE(Y,U,14),1:0)
+2 SET DIC="^DGPM("
SET DR=200
SET DIQ(0)="E"
SET DIQ="HLD($J,"
DO EN^DIQ1
KILL DIC,DR
SET X=$SELECT($DATA(HLD($JOB,405,DA,200,"E")):HLD($JOB,405,DA,200,"E"),1:0)
SET X=X_" "
SET Y=RTY
SET R2(CT)=$EXTRACT(X,1,20)_";"_M
SET Y=+Y
DO D^DIQ
SET R2(CT)=R2(CT)_"^"_Y
+3 KILL RTY,HLD($JOB,405,DA),DA
+4 QUIT
+5 ;
DPL ;Displays the admissions and discharges.
+1 DO LINE^RTUTL3
+2 FOR CT=1:1:3
IF $DATA(R3(CT))
WRITE !,$PIECE($TEXT(LABELS+CT),";;",2)," ",$EXTRACT($PIECE(R3(CT),"^")_" ",1,20),$PIECE(R3(CT),"^",2)
XXX FOR CT=4:1:5
IF $DATA(R2(CT))
WRITE !,$PIECE($TEXT(LABELS+CT),";;",2)," ",$EXTRACT($PIECE(R2(CT),"^")_" ",1,20),$PIECE(R2(CT),"^",2)
+1 QUIT
LABELS ;;
+1 ;;Clinic appoint :
+2 ;;Clinic appoint :
+3 ;;Clinic appoint :
+4 ;;Last Admission :
+5 ;;Last Discharge :
