DGOIL.m

DGOIL ;ALB/AAS - INPATIENT LIST ; 28-SEPT-90

 ;;5.3;Registration;**162,279,498,1015**;Aug 13, 1993;Build 21

 ;

% ; -- 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")

 ;

DGOIL     ;ALB/AAS - INPATIENT LIST ; 28-SEPT-90

 +1       ;;5.3;Registration;**162,279,498,1015**;Aug 13, 1993;Build 21

 +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       ;