- 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)
