DGPMTSO1 ;ALB/LM - TREATING SPECIALTY INPATIENT LISTING BY WARDS ;2-2-93
;;5.3;Registration;;Aug 13, 1993
;
START Q:'PTLWD
S REPORT="< < PATIENT LISTING BY WARD > >"
S (PAGE,TOTAL)=0
D HEAD^DGPMTSO
D SUBHEAD
;
DIV S DIV="" F DIV1=0:0 S DIV=$O(^TMP($J,"PTLWD",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 WARD Q:END S SUBCOUNT=^TMP($J,"PTLWD",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 PTLWD=0
;
END K ABSENCE,ADMDT,DGW,DGW1,DIV,DIV1,ID,IFN,L,PAGE,PTNM,PTNM1,REPORT,SUBCOUNT,TOTAL,TREAT,TSXFR,WARD,WARD1,PTLWD,SUBNAME
Q
;
WARD S WARD="" F WARD1=0:0 S WARD=$O(^TMP($J,"PTLWD",DIV,WARD)) Q:WARD="" Q:END D DGW
Q
;
DGW S DGW="" F DGW1=0:0 S DGW=$O(^TMP($J,"PTLWD",DIV,WARD,DGW)) Q:DGW="" D:$Y+8>IOSL HEAD^DGPMTSO,SUBHEAD Q:END W !!?10,"INPATIENT WARD: ",WARD D PTNM Q:END S SUBCOUNT=^TMP($J,"PTLWD",DIV,WARD,DGW) S SUBNAME="WARD" D SUB Q:END
Q
;
PTNM S PTNM="" F PTNM1=0:0 S PTNM=$O(^TMP($J,"PTLWD",DIV,WARD,DGW,PTNM)) Q:PTNM="" F IFN=0:0 S IFN=$O(^TMP($J,"PTLWD",DIV,WARD,DGW,PTNM,IFN)) Q:'IFN D INFO Q:END
Q
;
INFO S TREAT=$P(^TMP($J,"PTLWD",DIV,WARD,DGW,PTNM,IFN),"^")
S ADMDT=$P(^TMP($J,"PTLWD",DIV,WARD,DGW,PTNM,IFN),"^",2)
S TSXFR=$P(^TMP($J,"PTLWD",DIV,WARD,DGW,PTNM,IFN),"^",3)
S ABSENCE=$P(^TMP($J,"PTLWD",DIV,WARD,DGW,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,TREAT,?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,"LAST FACILITY TREATING SPECIALTY",?100,"LAST TS SERVICE",?120,"ABSENCE",!
F L=1:1:(IOM-3) W "-"
W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMTSO1 3084 printed Oct 16, 2024@18:50:35 Page 2
DGPMTSO1 ;ALB/LM - TREATING SPECIALTY INPATIENT LISTING BY WARDS ;2-2-93
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
START if 'PTLWD
QUIT
+1 SET REPORT="< < PATIENT LISTING BY WARD > >"
+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,"PTLWD",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 WARD
if END
QUIT
SET SUBCOUNT=^TMP($JOB,"PTLWD",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 PTLWD=0
+7 ;
END KILL ABSENCE,ADMDT,DGW,DGW1,DIV,DIV1,ID,IFN,L,PAGE,PTNM,PTNM1,REPORT,SUBCOUNT,TOTAL,TREAT,TSXFR,WARD,WARD1,PTLWD,SUBNAME
+1 QUIT
+2 ;
WARD SET WARD=""
FOR WARD1=0:0
SET WARD=$ORDER(^TMP($JOB,"PTLWD",DIV,WARD))
if WARD=""
QUIT
if END
QUIT
DO DGW
+1 QUIT
+2 ;
DGW SET DGW=""
FOR DGW1=0:0
SET DGW=$ORDER(^TMP($JOB,"PTLWD",DIV,WARD,DGW))
if DGW=""
QUIT
if $Y+8>IOSL
DO HEAD^DGPMTSO
DO SUBHEAD
if END
QUIT
WRITE !!?10,"INPATIENT WARD: ",WARD
DO PTNM
if END
QUIT
SET SUBCOUNT=^TMP($JOB,"PTLWD",DIV,WARD,DGW)
SET SUBNAME="WARD"
DO SUB
if END
QUIT
+1 QUIT
+2 ;
PTNM SET PTNM=""
FOR PTNM1=0:0
SET PTNM=$ORDER(^TMP($JOB,"PTLWD",DIV,WARD,DGW,PTNM))
if PTNM=""
QUIT
FOR IFN=0:0
SET IFN=$ORDER(^TMP($JOB,"PTLWD",DIV,WARD,DGW,PTNM,IFN))
if 'IFN
QUIT
DO INFO
if END
QUIT
+1 QUIT
+2 ;
INFO SET TREAT=$PIECE(^TMP($JOB,"PTLWD",DIV,WARD,DGW,PTNM,IFN),"^")
+1 SET ADMDT=$PIECE(^TMP($JOB,"PTLWD",DIV,WARD,DGW,PTNM,IFN),"^",2)
+2 SET TSXFR=$PIECE(^TMP($JOB,"PTLWD",DIV,WARD,DGW,PTNM,IFN),"^",3)
+3 SET ABSENCE=$PIECE(^TMP($JOB,"PTLWD",DIV,WARD,DGW,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,TREAT,?100,TSXFR,?120,ABSENCE
+1 QUIT
+2 ;
+3 ;
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(SUBCOUNT,"^",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,"LAST FACILITY TREATING SPECIALTY",?100,"LAST TS SERVICE",?120,"ABSENCE",!
+3 FOR L=1:1:(IOM-3)
WRITE "-"
+4 WRITE !
+5 QUIT
