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")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGOIL 4629 printed Dec 13, 2024@02:46:33 Page 2
DGOIL ;ALB/AAS - INPATIENT LIST ; 28-SEPT-90
+1 ;;5.3;Registration;**162,279,498**;Aug 13, 1993
+2 ;
% ; -- start here
+1 DO HOME^%ZIS
WRITE @IOF
+2 WRITE !!,?32,"Inpatient List",!!!
+3 ;
WARD ; -- by ward or by name
+1 SET DIR("B")="WARD"
SET DIR(0)="S^1:WARD;0:NAME"
SET DIR("A")="SORT BY"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END1
SET DGWARD=+Y
+2 ;
FIRST ; -- get range of the output
+1 SET DIR("B")="FIRST"
SET DIR(0)="F^1:30"
SET DIR("A")="START WITH "_$SELECT(DGWARD:"WARD LOCATION",1:"NAME")
+2 SET DIR("?",1)="Enter all or part of a ward name. If the FROM and TO wards are pure"
+3 SET DIR("?")="numbers (no alphas), no wards with an alpha suffix will appear on the sort."
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END1
+5 SET DGBEG=$$CAP(Y)
+6 if DGBEG="FIRST"
SET DGBEG=""
+7 ;
+8 SET DIR("B")="LAST"
SET DIR(0)="F^1:30"
SET DIR("A")="GO TO "_$SELECT(DGWARD:"WARD LOCATION",1:"NAME")
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END1
+9 SET DGEND=$$CAP(Y)
+10 if DGEND="LAST"
SET DGEND="ZZZZZZZ"
+11 ;
+12 IF DGBEG'=DGEND
IF DGBEG]DGEND
WRITE !!,"End must be after beginning",!
GOTO FIRST
+13 ; Ask Division (sets VAUTD)
+14 IF '$$ASKDIV^DGUTL()
GOTO END1
+15 ;
BRKOUT ; -- with ward breakout
+1 WRITE !!
SET DIR("B")="YES"
SET DIR(0)="Y"
SET DIR("A")="PRINT WITH WARD BREAKOUT"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END1
SET DGBRK=+Y
+2 ;
DRG ; -- with DGR breakout
+1 SET DGDRG=0
IF DGBRK
SET DIR("B")="YES"
SET DIR(0)="Y"
SET DIR("A")="PRINT WITH DRG BREAKOUT"
DO ^DIR
if $DATA(DIRUT)
GOTO END1
SET DGDRG=+Y
+2 ;
DEV if DGDRG
WRITE !,*7,"This output requires 132 column output"
+1 SET DGPGM="DQ^DGOIL"
SET DGVAR="DGWARD^DGBEG^DGEND^DGBRK^DGDRG^VAUTD#"
+2 DO ZIS^DGUTQ
if POP
GOTO END
USE IO
+3 ;
DQ ; -- entry point to start processing
+1 KILL ^UTILITY($JOB)
+2 SET (POP,DGPG)=0
DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
DO D^DIQ
SET DGDATE=Y
+3 SET AFFIL=$SELECT($DATA(^DG(43,1,"GL")):$PIECE(^("GL"),"^",4),1:0)
+4 if DGBEG]""&(+DGBEG'=DGBEG)
SET DGBEG=$EXTRACT(DGBEG,1,($LENGTH(DGBEG)-1))_$CHAR($ASCII($EXTRACT(DGBEG,$LENGTH(DGBEG)))-1)_"~"
+5 if DGBEG]""&(+DGBEG=DGBEG)
SET DGBEG=DGBEG-.0000001
+6 ;
SORT ; -- sort inpatients, store in ^utility($j,
+1 ;if sorting by ward start with DGBEG
SET W=$SELECT(DGWARD:DGBEG,1:"")
+2 FOR I=0:0
if W=DGEND
QUIT
SET W=$ORDER(^DPT("CN",W))
if W']""!(DGWARD&(W]DGEND))
QUIT
SET DFN=""
FOR J=0:0
SET DFN=$ORDER(^DPT("CN",W,DFN))
if 'DFN
QUIT
SET DGPM=^(DFN)
Begin DoDot:1
+3 IF 'VAUTD
SET DGWD=$ORDER(^DIC(42,"B",W,0))
if 'DGWD
QUIT
SET DGWD=$SELECT('$DATA(^DIC(42,DGWD,0)):0,+$PIECE(^(0),U,11):$PIECE(^(0),U,11),1:0)
if '$DATA(VAUTD(DGWD))
QUIT
+4 DO SETU
End DoDot:1
+5 ;
+6 DO HDR1
IF '$DATA(^UTILITY($JOB))
WRITE !,"No Matches Found"
GOTO END
BYWARD ; -- if by ward get entries to print
+1 IF DGWARD
SET W=""
FOR I=0:0
SET W=$ORDER(^UTILITY($JOB,W))
if W']""!($DATA(DUOUT))
QUIT
if $DATA(N)
DO HDR
SET N=""
FOR J=0:0
SET N=$ORDER(^UTILITY($JOB,W,N))
if N']""!($DATA(DUOUT))
QUIT
SET DFN=""
FOR K=0:0
SET DFN=$ORDER(^UTILITY($JOB,W,N,DFN))
if 'DFN!($DATA(DUOUT))
QUIT
SET DGPM=^(DFN)
DO ^DGOIL1
+2 ;
BYNAME ; -- if by name get entries to print
+1 IF 'DGWARD
SET N=DGBEG
FOR I=0:0
SET N=$ORDER(^UTILITY($JOB,N))
if N']""!(N]DGEND)!($DATA(DUOUT))
QUIT
SET W=""
FOR J=0:0
SET W=$ORDER(^UTILITY($JOB,N,W))
if W']""!($DATA(DUOUT))
QUIT
SET DFN=""
FOR K=0:0
SET DFN=$ORDER(^UTILITY($JOB,N,W,DFN))
if 'DFN!($DATA(DUOUT))
QUIT
SET DGPM=^(DFN)
DO ^DGOIL1
+2 GOTO END
+3 ;
SETU ; -- set utility($j,$s(sort by ward:ward,1:name),$s(sort by ward:name,1:ward),dfn)=pointer to dgpm
+1 if '$DATA(^DPT(DFN,0))
QUIT
+2 SET NAME=$PIECE(^DPT(DFN,0),"^")
+3 SET ^UTILITY($JOB,$SELECT(DGWARD:W,1:NAME),$SELECT(DGWARD:NAME,1:W),DFN)=DGPM
+4 QUIT
+5 ;
HDR DO LEGEND
if $DATA(DUOUT)
QUIT
HDR1 SET DGPG=DGPG+1
WRITE @IOF,"INPATIENT LIST",?(IOM-29)
WRITE DGDATE," PAGE: ",DGPG
+1 WRITE !,"Patient name",?19,"PT ID",?27,"Admit/Tran Ward",?51,"LOS AA Pass UA ASIH"
IF DGDRG
WRITE ?76,"DRG",?83,"Avg",?88,$SELECT('AFFIL:"non-",AFFIL=2:"Int-",1:"Affil"),?96,"L/H",?104,"local",?112,"Days to",?120,"% in ",?128,"flag"
+2 WRITE !?30,"date",?38,"location"
IF DGDRG
WRITE ?83,"LOS",?88,$SELECT(AFFIL'=1:"Affil",1:""),?96,"Trim",?104,"L/H",?112,"Trim",?120,"Trim"
+3 IF DGDRG
WRITE !?104,"Trim",?112,"Nat/Loc",?120,"Nat/Loc"
+4 WRITE !
FOR I=1:1:IOM
WRITE "="
+5 IF $DATA(^UTILITY($JOB))
IF DGWARD
WRITE !,?8,"WARD LOCATION: ",$SELECT('$DATA(N):$ORDER(^UTILITY($JOB,"")),$DATA(W):W,1:"")
Begin DoDot:1
+6 SET I=0
FOR
SET I=$ORDER(VAUTD(I))
if 'I
QUIT
WRITE ?45,"DIVISION(S): ",VAUTD(I),!
End DoDot:1
+7 QUIT
END KILL ^UTILITY($JOB)
if '$DATA(DUOUT)&('POP)&('$DATA(DIRUT))
DO LEGEND
if $DATA(ZTQUEUED)
QUIT
END1 KILL %,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
+1 DO ^%ZISC
QUIT
+2 ;
LEGEND ; -legend for flag column
+1 FOR L=1:1
if IOSL<($Y+6)
QUIT
WRITE !
+2 WRITE !,"'+' Before the Patient name indicates patient is currently ASIH, '!' Indicates patient chose not to be in Facility Directory"
+3 if DGDRG&($EXTRACT(IOST,1,2)'="C-")
WRITE !,"LEGEND: '####' - Stay exceeds high trim, '**' - Stay exceeds 69% of high trim, '@' Stay exceeds 49% of high trim"
+4 IF $EXTRACT(IOST,1,2)="C-"
READ !,"Press '^' to QUIT or Return to Continue",Z:DTIME
IF '$TEST!(Z["^")
SET DUOUT=1
QUIT
+5 QUIT
CAP(X) ; -convert lower case input to upper case.
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
