source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGOIL.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: 4.4 KB
Line 
1DGOIL ;ALB/AAS - INPATIENT LIST ; 28-SEPT-90
2 ;;5.3;Registration;**162,279,498**;Aug 13, 1993
3 ;
4% ; -- start here
5 D HOME^%ZIS W @IOF
6 W !!,?32,"Inpatient List",!!!
7 ;
8WARD ; -- by ward or by name
9 S DIR("B")="WARD",DIR(0)="S^1:WARD;0:NAME",DIR("A")="SORT BY" D ^DIR K DIR G:$D(DIRUT) END1 S DGWARD=+Y
10 ;
11FIRST ; -- get range of the output
12 S DIR("B")="FIRST",DIR(0)="F^1:30",DIR("A")="START WITH "_$S(DGWARD:"WARD LOCATION",1:"NAME")
13 S DIR("?",1)="Enter all or part of a ward name. If the FROM and TO wards are pure"
14 S DIR("?")="numbers (no alphas), no wards with an alpha suffix will appear on the sort."
15 D ^DIR K DIR G:$D(DIRUT) END1
16 S DGBEG=$$CAP(Y)
17 S:DGBEG="FIRST" DGBEG=""
18 ;
19 S DIR("B")="LAST",DIR(0)="F^1:30",DIR("A")="GO TO "_$S(DGWARD:"WARD LOCATION",1:"NAME") D ^DIR K DIR G:$D(DIRUT) END1
20 S DGEND=$$CAP(Y)
21 S:DGEND="LAST" DGEND="ZZZZZZZ"
22 ;
23 I DGBEG'=DGEND,DGBEG]DGEND W !!,"End must be after beginning",! G FIRST
24 ; Ask Division (sets VAUTD)
25 I '$$ASKDIV^DGUTL() G END1
26 ;
27BRKOUT ; -- with ward breakout
28 W !! S DIR("B")="YES",DIR(0)="Y",DIR("A")="PRINT WITH WARD BREAKOUT" D ^DIR K DIR G:$D(DIRUT) END1 S DGBRK=+Y
29 ;
30DRG ; -- with DGR breakout
31 S DGDRG=0 I DGBRK S DIR("B")="YES",DIR(0)="Y",DIR("A")="PRINT WITH DRG BREAKOUT" D ^DIR G:$D(DIRUT) END1 S DGDRG=+Y
32 ;
33DEV W:DGDRG !,*7,"This output requires 132 column output"
34 S DGPGM="DQ^DGOIL",DGVAR="DGWARD^DGBEG^DGEND^DGBRK^DGDRG^VAUTD#"
35 D ZIS^DGUTQ G:POP END U IO
36 ;
37DQ ; -- entry point to start processing
38 K ^UTILITY($J)
39 S (POP,DGPG)=0 D NOW^%DTC S Y=$E(%,1,12) D D^DIQ S DGDATE=Y
40 S AFFIL=$S($D(^DG(43,1,"GL")):$P(^("GL"),"^",4),1:0)
41 S:DGBEG]""&(+DGBEG'=DGBEG) DGBEG=$E(DGBEG,1,($L(DGBEG)-1))_$C($A($E(DGBEG,$L(DGBEG)))-1)_"~"
42 S:DGBEG]""&(+DGBEG=DGBEG) DGBEG=DGBEG-.0000001
43 ;
44SORT ; -- sort inpatients, store in ^utility($j,
45 S W=$S(DGWARD:DGBEG,1:"") ;if sorting by ward start with DGBEG
46 F I=0:0 Q:W=DGEND S W=$O(^DPT("CN",W)) Q:W']""!(DGWARD&(W]DGEND)) S DFN="" F J=0:0 S DFN=$O(^DPT("CN",W,DFN)) Q:'DFN S DGPM=^(DFN) D
47 .I 'VAUTD S DGWD=$O(^DIC(42,"B",W,0)) Q:'DGWD S DGWD=$S('$D(^DIC(42,DGWD,0)):0,+$P(^(0),U,11):$P(^(0),U,11),1:0) Q:'$D(VAUTD(DGWD))
48 .D SETU
49 ;
50 D HDR1 I '$D(^UTILITY($J)) W !,"No Matches Found" G END
51BYWARD ; -- if by ward get entries to print
52 I DGWARD S W="" F I=0:0 S W=$O(^UTILITY($J,W)) Q:W']""!($D(DUOUT)) D HDR:$D(N) S N="" F J=0:0 S N=$O(^UTILITY($J,W,N)) Q:N']""!($D(DUOUT)) S DFN="" F K=0:0 S DFN=$O(^UTILITY($J,W,N,DFN)) Q:'DFN!($D(DUOUT)) S DGPM=^(DFN) D ^DGOIL1
53 ;
54BYNAME ; -- if by name get entries to print
55 I 'DGWARD S N=DGBEG F I=0:0 S N=$O(^UTILITY($J,N)) Q:N']""!(N]DGEND)!($D(DUOUT)) S W="" F J=0:0 S W=$O(^UTILITY($J,N,W)) Q:W']""!($D(DUOUT)) S DFN="" F K=0:0 S DFN=$O(^UTILITY($J,N,W,DFN)) Q:'DFN!($D(DUOUT)) S DGPM=^(DFN) D ^DGOIL1
56 G END
57 ;
58SETU ; -- set utility($j,$s(sort by ward:ward,1:name),$s(sort by ward:name,1:ward),dfn)=pointer to dgpm
59 Q:'$D(^DPT(DFN,0))
60 S NAME=$P(^DPT(DFN,0),"^")
61 S ^UTILITY($J,$S(DGWARD:W,1:NAME),$S(DGWARD:NAME,1:W),DFN)=DGPM
62 Q
63 ;
64HDR D LEGEND Q:$D(DUOUT)
65HDR1 S DGPG=DGPG+1 W @IOF,"INPATIENT LIST",?(IOM-29) W DGDATE," PAGE: ",DGPG
66 W !,"Patient name",?19,"PT ID",?27,"Admit/Tran Ward",?51,"LOS AA Pass UA ASIH" I DGDRG W ?76,"DRG",?83,"Avg",?88,$S('AFFIL:"non-",AFFIL=2:"Int-",1:"Affil"),?96,"L/H",?104,"local",?112,"Days to",?120,"% in ",?128,"flag"
67 W !?30,"date",?38,"location" I DGDRG W ?83,"LOS",?88,$S(AFFIL'=1:"Affil",1:""),?96,"Trim",?104,"L/H",?112,"Trim",?120,"Trim"
68 I DGDRG W !?104,"Trim",?112,"Nat/Loc",?120,"Nat/Loc"
69 W ! F I=1:1:IOM W "="
70 I $D(^UTILITY($J)),DGWARD W !,?8,"WARD LOCATION: ",$S('$D(N):$O(^UTILITY($J,"")),$D(W):W,1:"") D
71 .S I=0 F S I=$O(VAUTD(I)) Q:'I W ?45,"DIVISION(S): ",VAUTD(I),!
72 Q
73END K ^UTILITY($J) D:'$D(DUOUT)&('POP)&('$D(DIRUT)) LEGEND Q:$D(ZTQUEUED)
74END1 K %,I,J,K,L,N,M,W,NAME,X,X1,X2,X3,Y,Z,AFFIL,DFN,VA,DGBEG,DGBRK,DGDATE,DGDRG,DGEND,DGPM,DGPGM,DGVAR,DGWARD,DIR,DUOUT,DGOUT,DGL,DRG,DRGCAL,DGPG,DIRUT,VAIN,DGASIH,ADM,DIS,VAUTD
75 D ^%ZISC Q
76 ;
77LEGEND ; -legend for flag column
78 F L=1:1 Q:IOSL<($Y+6) W !
79 W !,"'+' Before the Patient name indicates patient is currently ASIH, '!' Indicates patient chose not to be in Facility Directory"
80 W:DGDRG&($E(IOST,1,2)'="C-") !,"LEGEND: '####' - Stay exceeds high trim, '**' - Stay exceeds 69% of high trim, '@' Stay exceeds 49% of high trim"
81 I $E(IOST,1,2)="C-" R !,"Press '^' to QUIT or Return to Continue",Z:DTIME I '$T!(Z["^") S DUOUT=1 Q
82 Q
83CAP(X) ; -convert lower case input to upper case.
84 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
85 ;
Note: See TracBrowser for help on using the repository browser.