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