- DGPMTSO1 ;ALB/LM - TREATING SPECIALTY INPATIENT LISTING BY WARDS ;2-2-93
- ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- ;
- 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
- DGPMTSO1 ;ALB/LM - TREATING SPECIALTY INPATIENT LISTING BY WARDS ;2-2-93
- +1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- +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
