ADGSIL.m

ADGSIL ; IHS/ADC/PDW/ENM - SERIOUSLY ILL LIST ; [ 03/25/1999  11:48 AM ]

 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 ;

 W @IOF,!!!?31,"PATIENTS CURRENTLY ON SERIOUSLY ILL LIST",!!

A ; -- driver

 D ZIS I POP D Q Q

 I $D(IO("Q")) D QUE,Q Q

 D LW,Q Q

 ;

LW ;EP; -- loop inpatients

 U IO D HD

 S WD="" F  S WD=$O(^DPT("CN",WD)) Q:WD=""  D

 . S DFN=0 F  S DFN=$O(^DPT("CN",WD,DFN)) Q:'DFN  D WRT

 Q

 ;

WRT ;

 Q:'$D(^DPT(DFN,"DAC"))  Q:$P(^("DAC"),U)'="S"

 W !,$E($P($G(^DPT(+DFN,0)),U),1,20),?25,$$HRCN^ADGF

 W ?37,$E($$PR,1,15),?55,$$AGE,?63,$$WD,?68,$E($$TS,1,3)

 I $Y>(IOSL-7) D NPG

 Q

 ;

HD ;print heading

 I IOST["C-" W @IOF

 W ?11,"*****Confidential Patient Data Covered by Privacy Act*****"

 W !!?31,"SERIOUSLY ILL LIST",!

 W ?34,"for ",$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),!!

 W !,"Patient Name",?25,"Chart #",?37,"Provider",?55,"Age"

 W ?63,"WD",?68,"SRV",!

 Q

 ;

Q I IOST?1"C-".E K DIR S DIR(0)="E" D ^DIR

 W @IOF D ^%ZISC,HOME^%ZIS

 K ZTSK,DFN,WD Q

 ;

NPG I IOST'?1"C-".E D HD Q

 K DIR S DIR(0)="E" D ^DIR K DIR,X D:'$D(DIRUT) HD Q

 ;

ZIS ; -- device selection

 S %ZIS="PQ" D ^%ZIS Q

 ;

QUE ; -- queued output

 K IO("Q") S ZTRTN="LW^ADGSIL",ZTDESC="SI LIST" D ^%ZTLOAD Q

 ;

AGE() ; -- age

 N X,DIC,DR,DA

 K ^UTILITY("DIQ1",$J) S DIC=9000001,DR=1102.98,DA=DFN D EN^DIQ1

 S X=$G(^UTILITY("DIQ1",$J,9000001,DFN,1102.98)) K ^UTILITY("DIQ1",$J)

 Q X

 ;

PR() ; -- provider

 Q $E($P($G(^VA(200,+$G(^DPT(DFN,.104)),0)),U),1,21)

 ;

TS() ; -- treating specialty

 Q $E($P($G(^DIC(45.7,+$G(^DPT(DFN,.103)),0)),U),1,3)

 ;

WD() ; -- ward

 Q $E($P($G(^DIC(42,+$G(^DPT(DFN,.1)),0)),U),1,3)

ADGSIL    ; IHS/ADC/PDW/ENM - SERIOUSLY ILL LIST ; [ 03/25/1999  11:48 AM ]

 +1       ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 +2       ;

 +3        WRITE @IOF,!!!?31,"PATIENTS CURRENTLY ON SERIOUSLY ILL LIST",!!

A         ; -- driver

 +1        DO ZIS

           IF POP

               DO Q

               QUIT 

 +2        IF $DATA(IO("Q"))

               DO QUE

               DO Q

               QUIT 

 +3        DO LW

           DO Q

           QUIT 

 +4       ;

LW        ;EP; -- loop inpatients

 +1        USE IO

           DO HD

 +2        SET WD=""

           FOR 

               SET WD=$ORDER(^DPT("CN",WD))

               IF WD=""

                   QUIT 

               Begin DoDot:1

 +3                SET DFN=0

                   FOR 

                       SET DFN=$ORDER(^DPT("CN",WD,DFN))

                       IF 'DFN

                           QUIT 

                       DO WRT

               End DoDot:1

 +4        QUIT 

 +5       ;

WRT       ;

 +1        IF '$DATA(^DPT(DFN,"DAC"))

               QUIT 

           IF $PIECE(^("DAC"),U)'="S"

               QUIT 

 +2        WRITE !,$EXTRACT($PIECE($GET(^DPT(+DFN,0)),U),1,20),?25,$$HRCN^ADGF

 +3        WRITE ?37,$EXTRACT($$PR,1,15),?55,$$AGE,?63,$$WD,?68,$EXTRACT($$TS,1,3)

 +4        IF $Y>(IOSL-7)

               DO NPG

 +5        QUIT 

 +6       ;

HD        ;print heading

 +1        IF IOST["C-"

               WRITE @IOF

 +2        WRITE ?11,"*****Confidential Patient Data Covered by Privacy Act*****"

 +3        WRITE !!?31,"SERIOUSLY ILL LIST",!

 +4        WRITE ?34,"for ",$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3),!!

 +5        WRITE !,"Patient Name",?25,"Chart #",?37,"Provider",?55,"Age"

 +6        WRITE ?63,"WD",?68,"SRV",!

 +7        QUIT 

 +8       ;

Q          IF IOST?1"C-".E

               KILL DIR

               SET DIR(0)="E"

               DO ^DIR

 +1        WRITE @IOF

           DO ^%ZISC

           DO HOME^%ZIS

 +2        KILL ZTSK,DFN,WD

           QUIT 

 +3       ;

NPG        IF IOST'?1"C-".E

               DO HD

               QUIT 

 +1        KILL DIR

           SET DIR(0)="E"

           DO ^DIR

           KILL DIR,X

           IF '$DATA(DIRUT)

               DO HD

           QUIT 

 +2       ;

ZIS       ; -- device selection

 +1        SET %ZIS="PQ"

           DO ^%ZIS

           QUIT 

 +2       ;

QUE       ; -- queued output

 +1        KILL IO("Q")

           SET ZTRTN="LW^ADGSIL"

           SET ZTDESC="SI LIST"

           DO ^%ZTLOAD

           QUIT 

 +2       ;

AGE()     ; -- age

 +1        NEW X,DIC,DR,DA

 +2        KILL ^UTILITY("DIQ1",$JOB)

           SET DIC=9000001

           SET DR=1102.98

           SET DA=DFN

           DO EN^DIQ1

 +3        SET X=$GET(^UTILITY("DIQ1",$JOB,9000001,DFN,1102.98))

           KILL ^UTILITY("DIQ1",$JOB)

 +4        QUIT X

 +5       ;

PR()      ; -- provider

 +1        QUIT $EXTRACT($PIECE($GET(^VA(200,+$GET(^DPT(DFN,.104)),0)),U),1,21)

 +2       ;

TS()      ; -- treating specialty

 +1        QUIT $EXTRACT($PIECE($GET(^DIC(45.7,+$GET(^DPT(DFN,.103)),0)),U),1,3)

 +2       ;

WD()      ; -- ward

 +1        QUIT $EXTRACT($PIECE($GET(^DIC(42,+$GET(^DPT(DFN,.1)),0)),U),1,3)