DGPMTSO2 ;ALB/LM - TREATING SPECIALTY INPATIENT LISTING BY TS ;2-2-93
;;5.3;Registration;;Aug 13, 1993
;
START Q:'PTLTS
S REPORT="< < PATIENT LISTING BY TREATING SPECIALTY > >"
S (PAGE,TOTAL)=0
D HEAD^DGPMTSO
D SUBHEAD
;
DIV S DIV="" F DIV1=0:0 S DIV=$O(^TMP($J,"PTLTS",DIV)) Q:DIV="" D:$Y+8>IOSL HEAD^DGPMTSO,SUBHEAD Q:END W !?5,"DIVISION: ",$S($D(^DG(40.8,DIV,0)):$P(^(0),"^"),1:"EMPTY") D TREAT Q:END S SUBCOUNT=^TMP($J,"PTLTS",DIV) D TOTAL Q:END
;
G:END END
D:$Y+8>IOSL HEAD^DGPMTSO,SUBHEAD Q:END
F L=1:1:(IOM-3) W "-"
W !!?3,"TOTAL = ",$J($P(TOTAL,"^",1),4),?25,"PASS = ",$J($P(TOTAL,"^",2),4),?45,"AA = ",$J($P(TOTAL,"^",3),4),?65,"UA = ",$J($P(TOTAL,"^",4),4),?85,"ASIH = ",$J($P(TOTAL,"^",5),4),?105,"PTS REMAINING = ",$J($P(TOTAL,"^",6),4)
S PTLTS=0
;
END K ADMDT,DGTS,DGTS1,DIV,DIV1,ID,IFN,L,PAGE,PTNM,PTNM1,REPORT,SUBCOUNT,TOTAL,TREAT,TREAT1,TSXFR,WARD,PTLTS,SUBNAME
Q
;
TREAT S TREAT="" F TREAT1=0:0 S TREAT=$O(^TMP($J,"PTLTS",DIV,TREAT)) Q:TREAT="" Q:END D DGTS
Q
;
DGTS S DGTS="" F DGTS1=0:0 S DGTS=$O(^TMP($J,"PTLTS",DIV,TREAT,DGTS)) Q:DGTS="" D:$Y+8>IOSL HEAD^DGPMTSO,SUBHEAD Q:END W !!?10,"FACILITY TREATING SPECIALTY: ",TREAT D PTNM Q:END S SUBCOUNT=^TMP($J,"PTLTS",DIV,TREAT,DGTS) S SUBNAME="TS" D SUB
Q
;
PTNM S PTNM="" F PTNM1=0:0 S PTNM=$O(^TMP($J,"PTLTS",DIV,TREAT,DGTS,PTNM)) Q:PTNM="" F IFN=0:0 S IFN=$O(^TMP($J,"PTLTS",DIV,TREAT,DGTS,PTNM,IFN)) Q:'IFN D INFO Q:END
Q
;
INFO S WARD=$P(^TMP($J,"PTLTS",DIV,TREAT,DGTS,PTNM,IFN),"^")
S ADMDT=$P(^TMP($J,"PTLTS",DIV,TREAT,DGTS,PTNM,IFN),"^",2)
S TSXFR=$P(^TMP($J,"PTLTS",DIV,TREAT,DGTS,PTNM,IFN),"^",3)
S ABSENCE=$P(^TMP($J,"PTLTS",DIV,TREAT,DGTS,PTNM,IFN),"^",4)
S ID=$S($D(^DPT(IFN,.36)):$P(^DPT(IFN,.36),"^",3),1:"")
;
I $Y+8>IOSL D HEAD^DGPMTSO,SUBHEAD Q:END
LINE W !,PTNM,?30,ID,?45,ADMDT,?65,WARD,?100,TSXFR,?120,ABSENCE
Q
;
TOTAL S $P(TOTAL,"^",1)=$P(TOTAL,"^",1)+$P(SUBCOUNT,"^",1) ; current patients
S $P(TOTAL,"^",2)=$P(TOTAL,"^",2)+$P(SUBCOUNT,"^",2) ; pass
S $P(TOTAL,"^",3)=$P(TOTAL,"^",3)+$P(SUBCOUNT,"^",3) ; aa
S $P(TOTAL,"^",4)=$P(TOTAL,"^",4)+$P(SUBCOUNT,"^",4) ; ua
S $P(TOTAL,"^",5)=$P(TOTAL,"^",5)+$P(SUBCOUNT,"^",5) ; asih
S $P(TOTAL,"^",6)=$P(TOTAL,"^")-$P(TOTAL,"^",3)-$P(TOTAL,"^",4)-$P(TOTAL,"^",5) ; Current patient minus absences except Pass equals patient's remaining.
;
S SUBNAME="DIVISION"
;
SUB D:$Y+6>IOSL HEAD^DGPMTSO Q:END
;
S $P(SUBCOUNT,"^",6)=$P(SUBCOUNT,"^")-$P(SUBCOUNT,"^",3)-$P(SUBCOUNT,"^",4)-$P(SUBCOUNT,"^",5) ; Current patient minus absences except Pass equals patient's remaining.
W !
F L=1:1:(IOM-3) W "-"
W !,SUBNAME,!
W "SUBCOUNT = ",$J($P(SUBCOUNT,"^",1),4),?25,"PASS = ",$J($P(SUBCOUNT,"^",2),4),?45,"AA = ",$J($P(SUBCOUNT,"^",3),4),?65,"UA = ",$J($P(SUBCOUNT,"^",4),4),?85,"ASIH = ",$J($P(SUBCOUNT,"^",5),4)
W ?105,"PTS REMAINING = ",$J($P(SUBCOUNT,"^",6),4),!
Q
;
SUBHEAD ;
Q:END
W !!,"PATIENT",?30,"PT'S ID",?45,"ADMISSION DATE",?65,"INPATIENT WARD",?100,"LAST TS SERVICE",?120,"ABSENCE",!
F L=1:1:(IOM-3) W "-"
W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMTSO2 3089 printed Sep 23, 2025@20:25:51 Page 2
DGPMTSO2 ;ALB/LM - TREATING SPECIALTY INPATIENT LISTING BY TS ;2-2-93
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
START if 'PTLTS
QUIT
+1 SET REPORT="< < PATIENT LISTING BY TREATING SPECIALTY > >"
+2 SET (PAGE,TOTAL)=0
+3 DO HEAD^DGPMTSO
+4 DO SUBHEAD
+5 ;
DIV SET DIV=""
FOR DIV1=0:0
SET DIV=$ORDER(^TMP($JOB,"PTLTS",DIV))
if DIV=""
QUIT
if $Y+8>IOSL
DO HEAD^DGPMTSO
DO SUBHEAD
if END
QUIT
WRITE !?5,"DIVISION: ",$SELECT($DATA(^DG(40.8,DIV,0)):$PIECE(^(0),"^"),1:"EMPTY")
DO TREAT
if END
QUIT
SET SUBCOUNT=^TMP($JOB,"PTLTS",DIV)
DO TOTAL
if END
QUIT
+1 ;
+2 if END
GOTO END
+3 if $Y+8>IOSL
DO HEAD^DGPMTSO
DO SUBHEAD
if END
QUIT
+4 FOR L=1:1:(IOM-3)
WRITE "-"
+5 WRITE !!?3,"TOTAL = ",$JUSTIFY($PIECE(TOTAL,"^",1),4),?25,"PASS = ",$JUSTIFY($PIECE(TOTAL,"^",2),4),?45,"AA = ",...
... $JUSTIFY($PIECE(TOTAL,"^",3),4),?65,"UA = ",$JUSTIFY($PIECE(TOTAL,"^",4),4),?85,"ASIH = ",$JUSTIFY($PIECE(TOTAL,"^",5),4),?105,"PTS REMAINING = ",$JUSTIFY($PIECE(TOTAL,"^",6),4)
+6 SET PTLTS=0
+7 ;
END KILL ADMDT,DGTS,DGTS1,DIV,DIV1,ID,IFN,L,PAGE,PTNM,PTNM1,REPORT,SUBCOUNT,TOTAL,TREAT,TREAT1,TSXFR,WARD,PTLTS,SUBNAME
+1 QUIT
+2 ;
TREAT SET TREAT=""
FOR TREAT1=0:0
SET TREAT=$ORDER(^TMP($JOB,"PTLTS",DIV,TREAT))
if TREAT=""
QUIT
if END
QUIT
DO DGTS
+1 QUIT
+2 ;
DGTS SET DGTS=""
FOR DGTS1=0:0
SET DGTS=$ORDER(^TMP($JOB,"PTLTS",DIV,TREAT,DGTS))
if DGTS=""
QUIT
if $Y+8>IOSL
DO HEAD^DGPMTSO
DO SUBHEAD
if END
QUIT
WRITE !!?10,"FACILITY TREATING SPECIALTY: ",TREAT
DO PTNM
if END
QUIT
SET SUBCOUNT=^TMP($JOB,"PTLTS",DIV,TREAT,DGTS)
SET SUBNAME="TS"
DO SUB
+1 QUIT
+2 ;
PTNM SET PTNM=""
FOR PTNM1=0:0
SET PTNM=$ORDER(^TMP($JOB,"PTLTS",DIV,TREAT,DGTS,PTNM))
if PTNM=""
QUIT
FOR IFN=0:0
SET IFN=$ORDER(^TMP($JOB,"PTLTS",DIV,TREAT,DGTS,PTNM,IFN))
if 'IFN
QUIT
DO INFO
if END
QUIT
+1 QUIT
+2 ;
INFO SET WARD=$PIECE(^TMP($JOB,"PTLTS",DIV,TREAT,DGTS,PTNM,IFN),"^")
+1 SET ADMDT=$PIECE(^TMP($JOB,"PTLTS",DIV,TREAT,DGTS,PTNM,IFN),"^",2)
+2 SET TSXFR=$PIECE(^TMP($JOB,"PTLTS",DIV,TREAT,DGTS,PTNM,IFN),"^",3)
+3 SET ABSENCE=$PIECE(^TMP($JOB,"PTLTS",DIV,TREAT,DGTS,PTNM,IFN),"^",4)
+4 SET ID=$SELECT($DATA(^DPT(IFN,.36)):$PIECE(^DPT(IFN,.36),"^",3),1:"")
+5 ;
+6 IF $Y+8>IOSL
DO HEAD^DGPMTSO
DO SUBHEAD
if END
QUIT
LINE WRITE !,PTNM,?30,ID,?45,ADMDT,?65,WARD,?100,TSXFR,?120,ABSENCE
+1 QUIT
+2 ;
TOTAL ; current patients
SET $PIECE(TOTAL,"^",1)=$PIECE(TOTAL,"^",1)+$PIECE(SUBCOUNT,"^",1)
+1 ; pass
SET $PIECE(TOTAL,"^",2)=$PIECE(TOTAL,"^",2)+$PIECE(SUBCOUNT,"^",2)
+2 ; aa
SET $PIECE(TOTAL,"^",3)=$PIECE(TOTAL,"^",3)+$PIECE(SUBCOUNT,"^",3)
+3 ; ua
SET $PIECE(TOTAL,"^",4)=$PIECE(TOTAL,"^",4)+$PIECE(SUBCOUNT,"^",4)
+4 ; asih
SET $PIECE(TOTAL,"^",5)=$PIECE(TOTAL,"^",5)+$PIECE(SUBCOUNT,"^",5)
+5 ; Current patient minus absences except Pass equals patient's remaining.
SET $PIECE(TOTAL,"^",6)=$PIECE(TOTAL,"^")-$PIECE(TOTAL,"^",3)-$PIECE(TOTAL,"^",4)-$PIECE(TOTAL,"^",5)
+6 ;
+7 SET SUBNAME="DIVISION"
+8 ;
SUB if $Y+6>IOSL
DO HEAD^DGPMTSO
if END
QUIT
+1 ;
+2 ; Current patient minus absences except Pass equals patient's remaining.
SET $PIECE(SUBCOUNT,"^",6)=$PIECE(SUBCOUNT,"^")-$PIECE(SUBCOUNT,"^",3)-$PIECE(SUBCOUNT,"^",4)-$PIECE(SUBCOUNT,"^",5)
+3 WRITE !
+4 FOR L=1:1:(IOM-3)
WRITE "-"
+5 WRITE !,SUBNAME,!
+6 WRITE "SUBCOUNT = ",$JUSTIFY($PIECE(SUBCOUNT,"^",1),4),?25,"PASS = ",$JUSTIFY($PIECE(SUBCOUNT,"^",2),4),?45,"AA = ",$JUSTIFY($PIECE(SUBCOUNT,"^",3),4),?65,"UA = ",$JUSTIFY($PIECE(SUBCOUNT,"^",4),4),?85,"ASIH = ",$JUSTIFY($PIECE(SUBCOUN
T,"^",5),4)
+7 WRITE ?105,"PTS REMAINING = ",$JUSTIFY($PIECE(SUBCOUNT,"^",6),4),!
+8 QUIT
+9 ;
SUBHEAD ;
+1 if END
QUIT
+2 WRITE !!,"PATIENT",?30,"PT'S ID",?45,"ADMISSION DATE",?65,"INPATIENT WARD",?100,"LAST TS SERVICE",?120,"ABSENCE",!
+3 FOR L=1:1:(IOM-3)
WRITE "-"
+4 WRITE !
+5 QUIT
