source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGOIL.m@ 643

DGOIL ;ALB/AAS - INPATIENT LIST ; 28-SEPT-90
 ;;5.3;Registration;**162,279,498**;Aug 13, 1993
 ;
% ; -- start here
 D HOME^%ZIS W @IOF
 W !!,?32,"Inpatient List",!!!
 ;
WARD ; -- by ward or by name
 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
 ;
FIRST ; -- get range of the output
 S DIR("B")="FIRST",DIR(0)="F^1:30",DIR("A")="START WITH "_$S(DGWARD:"WARD LOCATION",1:"NAME")
 S DIR("?",1)="Enter all or part of a ward name.  If the FROM and TO wards are pure"
 S DIR("?")="numbers (no alphas), no wards with an alpha suffix will appear on the sort."
 D ^DIR K DIR G:$D(DIRUT) END1
 S DGBEG=$$CAP(Y)
 S:DGBEG="FIRST" DGBEG=""
 ;
 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
 S DGEND=$$CAP(Y)
 S:DGEND="LAST" DGEND="ZZZZZZZ"
 ;
 I DGBEG'=DGEND,DGBEG]DGEND W !!,"End must be after beginning",! G FIRST
 ; Ask Division (sets VAUTD)
 I '$$ASKDIV^DGUTL() G END1
 ;
BRKOUT ; -- with ward breakout
 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
 ;
DRG ; -- with DGR breakout
 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
 ;
DEV W:DGDRG !,*7,"This output requires 132 column output"
 S DGPGM="DQ^DGOIL",DGVAR="DGWARD^DGBEG^DGEND^DGBRK^DGDRG^VAUTD#"
 D ZIS^DGUTQ G:POP END U IO
 ;
DQ ;  -- entry point to start processing
 K ^UTILITY($J)
 S (POP,DGPG)=0 D NOW^%DTC S Y=$E(%,1,12) D D^DIQ S DGDATE=Y
 S AFFIL=$S($D(^DG(43,1,"GL")):$P(^("GL"),"^",4),1:0)
 S:DGBEG]""&(+DGBEG'=DGBEG) DGBEG=$E(DGBEG,1,($L(DGBEG)-1))_$C($A($E(DGBEG,$L(DGBEG)))-1)_"~"
 S:DGBEG]""&(+DGBEG=DGBEG) DGBEG=DGBEG-.0000001
 ;
SORT ;  -- sort inpatients, store in ^utility($j,
 S W=$S(DGWARD:DGBEG,1:"") ;if sorting by ward start with DGBEG
 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
 .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))
 .D SETU
 ;
 D HDR1 I '$D(^UTILITY($J)) W !,"No Matches Found" G END
BYWARD ; -- if by ward get entries to print
 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
 ;
BYNAME ;  -- if by name get entries to print
 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
 G END
 ;
SETU ;  -- set utility($j,$s(sort by ward:ward,1:name),$s(sort by ward:name,1:ward),dfn)=pointer to dgpm
 Q:'$D(^DPT(DFN,0))
 S NAME=$P(^DPT(DFN,0),"^")
 S ^UTILITY($J,$S(DGWARD:W,1:NAME),$S(DGWARD:NAME,1:W),DFN)=DGPM
 Q
 ;
HDR D LEGEND Q:$D(DUOUT)
HDR1 S DGPG=DGPG+1 W @IOF,"INPATIENT LIST",?(IOM-29) W DGDATE,"  PAGE: ",DGPG
 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"
 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"
 I DGDRG W !?104,"Trim",?112,"Nat/Loc",?120,"Nat/Loc"
 W ! F I=1:1:IOM W "="
 I $D(^UTILITY($J)),DGWARD W !,?8,"WARD LOCATION: ",$S('$D(N):$O(^UTILITY($J,"")),$D(W):W,1:"") D
 .S I=0 F  S I=$O(VAUTD(I)) Q:'I  W ?45,"DIVISION(S): ",VAUTD(I),!
 Q
END K ^UTILITY($J) D:'$D(DUOUT)&('POP)&('$D(DIRUT)) LEGEND Q:$D(ZTQUEUED)
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
 D ^%ZISC Q
 ;
LEGEND ;  -legend for flag column
 F L=1:1 Q:IOSL<($Y+6)  W !
 W !,"'+' Before the Patient name indicates patient is currently ASIH, '!' Indicates patient chose not to be in Facility Directory"
 W:DGDRG&($E(IOST,1,2)'="C-") !,"LEGEND:  '####' - Stay exceeds high trim,  '**' - Stay exceeds 69% of high trim,  '@' Stay exceeds 49% of high trim"
 I $E(IOST,1,2)="C-" R !,"Press '^' to QUIT or Return to Continue",Z:DTIME I '$T!(Z["^") S DUOUT=1 Q
 Q
CAP(X)  ; -convert lower case input to upper case.
 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 ;