source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMTSO2.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1DGPMTSO2 ;ALB/LM - TREATING SPECIALTY INPATIENT LISTING BY TS ;2-2-93
2 ;;5.3;Registration;;Aug 13, 1993
3 ;
4START Q:'PTLTS
5 S REPORT="< < PATIENT LISTING BY TREATING SPECIALTY > >"
6 S (PAGE,TOTAL)=0
7 D HEAD^DGPMTSO
8 D SUBHEAD
9 ;
10DIV 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
11 ;
12 G:END END
13 D:$Y+8>IOSL HEAD^DGPMTSO,SUBHEAD Q:END
14 F L=1:1:(IOM-3) W "-"
15 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)
16 S PTLTS=0
17 ;
18END K ADMDT,DGTS,DGTS1,DIV,DIV1,ID,IFN,L,PAGE,PTNM,PTNM1,REPORT,SUBCOUNT,TOTAL,TREAT,TREAT1,TSXFR,WARD,PTLTS,SUBNAME
19 Q
20 ;
21TREAT S TREAT="" F TREAT1=0:0 S TREAT=$O(^TMP($J,"PTLTS",DIV,TREAT)) Q:TREAT="" Q:END D DGTS
22 Q
23 ;
24DGTS 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
25 Q
26 ;
27PTNM 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
28 Q
29 ;
30INFO S WARD=$P(^TMP($J,"PTLTS",DIV,TREAT,DGTS,PTNM,IFN),"^")
31 S ADMDT=$P(^TMP($J,"PTLTS",DIV,TREAT,DGTS,PTNM,IFN),"^",2)
32 S TSXFR=$P(^TMP($J,"PTLTS",DIV,TREAT,DGTS,PTNM,IFN),"^",3)
33 S ABSENCE=$P(^TMP($J,"PTLTS",DIV,TREAT,DGTS,PTNM,IFN),"^",4)
34 S ID=$S($D(^DPT(IFN,.36)):$P(^DPT(IFN,.36),"^",3),1:"")
35 ;
36 I $Y+8>IOSL D HEAD^DGPMTSO,SUBHEAD Q:END
37LINE W !,PTNM,?30,ID,?45,ADMDT,?65,WARD,?100,TSXFR,?120,ABSENCE
38 Q
39 ;
40TOTAL S $P(TOTAL,"^",1)=$P(TOTAL,"^",1)+$P(SUBCOUNT,"^",1) ; current patients
41 S $P(TOTAL,"^",2)=$P(TOTAL,"^",2)+$P(SUBCOUNT,"^",2) ; pass
42 S $P(TOTAL,"^",3)=$P(TOTAL,"^",3)+$P(SUBCOUNT,"^",3) ; aa
43 S $P(TOTAL,"^",4)=$P(TOTAL,"^",4)+$P(SUBCOUNT,"^",4) ; ua
44 S $P(TOTAL,"^",5)=$P(TOTAL,"^",5)+$P(SUBCOUNT,"^",5) ; asih
45 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.
46 ;
47 S SUBNAME="DIVISION"
48 ;
49SUB D:$Y+6>IOSL HEAD^DGPMTSO Q:END
50 ;
51 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.
52 W !
53 F L=1:1:(IOM-3) W "-"
54 W !,SUBNAME,!
55 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)
56 W ?105,"PTS REMAINING = ",$J($P(SUBCOUNT,"^",6),4),!
57 Q
58 ;
59SUBHEAD ;
60 Q:END
61 W !!,"PATIENT",?30,"PT'S ID",?45,"ADMISSION DATE",?65,"INPATIENT WARD",?100,"LAST TS SERVICE",?120,"ABSENCE",!
62 F L=1:1:(IOM-3) W "-"
63 W !
64 Q
Note: See TracBrowser for help on using the repository browser.