| 1 | DGOIL ;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 | ;
|
|---|
| 8 | WARD ; -- 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 | ;
|
|---|
| 11 | FIRST ; -- 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 | ;
|
|---|
| 27 | BRKOUT ; -- 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 | ;
|
|---|
| 30 | DRG ; -- 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 | ;
|
|---|
| 33 | DEV 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 | ;
|
|---|
| 37 | DQ ; -- 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 | ;
|
|---|
| 44 | SORT ; -- 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
|
|---|
| 51 | BYWARD ; -- 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 | ;
|
|---|
| 54 | BYNAME ; -- 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 | ;
|
|---|
| 58 | SETU ; -- 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 | ;
|
|---|
| 64 | HDR D LEGEND Q:$D(DUOUT)
|
|---|
| 65 | HDR1 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
|
|---|
| 73 | END K ^UTILITY($J) D:'$D(DUOUT)&('POP)&('$D(DIRUT)) LEGEND Q:$D(ZTQUEUED)
|
|---|
| 74 | END1 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 | ;
|
|---|
| 77 | LEGEND ; -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
|
|---|
| 83 | CAP(X) ; -convert lower case input to upper case.
|
|---|
| 84 | Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|---|
| 85 | ;
|
|---|
