ADGSIL1 ; IHS/ADC/PDW/ENM - SI/DNR LISTING ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
W @IOF,!!! K ^TMP("DGZSIL",$J)
W ?10,"PATIENTS CURRENTLY ON SERIOUSLY ILL/DO NOT RESUSCITATE LIST",!!
A ; -- main
D ZIS I POP D Q Q
I $D(IO("Q")) D QUE,Q Q
D LW,WRT,Q Q
;
START ; -- queued output driver
K ^TMP("DGZSIL",$J)
D LW,WRT,Q Q
;
LW ; -- loop inpatients
N WD,DFN,WARD,NAME,TS,PR,CON,CDT,UTL,N,X
S WARD="" F S WARD=$O(^DPT("CN",WARD)) Q:WARD="" D
. S DFN=0 F S DFN=$O(^DPT("CN",WARD,DFN)) Q:'DFN D VAR
Q
;
VAR ;
Q:'$D(^DPT(DFN,"DAC")) Q:$P(^("DAC"),U)="" S N=^("DAC")
S NAME=$P($G(^DPT(DFN,0)),U),TS=$G(^(.103)),PR=$G(^(.104))
S WD=$O(^DIC(42,"B",WARD,0)),CON=$P(N,U),CDT=$P(N,U,2)
S UTL=$$AGE_U_TS_U_PR_U_$$HRCN^ADGF_U_WARD_U_CDT
I CON="S"!(CON="B") S ^TMP("DGZSIL",$J,1,NAME,DFN)=UTL
I CON="D"!(CON="B") S ^TMP("DGZSIL",$J,2,NAME,DFN)=UTL
Q
;
WRT ; -- loop utl
N WD,DFN,WARD,NAME,TS,PR,CON,CDT,UTL,N,X
U IO D HD S SI=0 F S SI=$O(^TMP("DGZSIL",$J,SI)) Q:'SI D
. W !!?28,$$HD1,!
. S NAME="" F S NAME=$O(^TMP("DGZSIL",$J,SI,NAME)) Q:NAME="" D
.. S DFN=0 F S DFN=$O(^TMP("DGZSIL",$J,SI,NAME,DFN)) Q:'DFN D 1 Q:$D(DIRUT)
Q
;
1 S N=^TMP("DGZSIL",$J,SI,NAME,DFN)
W !,$E(NAME,1,20),?23,$P(N,U,4)
W ?32,$E($P($G(^VA(200,+$P(N,U,3),0)),U),1,12)
W ?48,$P(N,U),?57,$P(N,U,5),?63,$E($G(^DIC(45.7,+$P(N,U,2),0)),1,3)
W ?69,$E($P(N,U,6),4,5)_"/"_$E($P(N,U,6),6,7)_"/"_$E($P(N,U,6),2,3)
I $Y>(IOSL-7) D NPG
Q
;
HD ; -- heading
I IOST["C-" W @IOF
W ?11,"*****Confidential Patient Data Covered by Privacy Act*****"
W !!?22,"SERIOUSLY ILL/DO NOT RESUSCITATE LIST",!
W ?34,"for ",$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),!!
W !,"Patient Name",?23,"Chart #",?32,"Provider",?48,"Age"
W ?57,"WD",?63,"SRV",?69,"Entered" Q
;
ZIS ; -- device selection
S %ZIS="PQ" D ^%ZIS Q
;
QUE ; -- queued output
S ZTRTN="START^ADGSIL1",ZTDESC="SI/DNR LIST" D ^%ZTLOAD Q
;
NPG ; -- end of page
I IOST'?1"C-".E D HD Q
K DIR S DIR(0)="E" D ^DIR D:'$D(DIRUT) HD Q
;
Q ; -- cleanup
I IOST?1"C-".E D PRTOPT^ADGVAR
W @IOF D ^%ZISC,HOME^%ZIS K ZTSK,IO("Q") 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=^UTILITY("DIQ1",$J,9000001,DFN,1102.98) K ^UTILITY("DIQ1",$J)
Q X
;
HD1() ; -- heading
Q $S(SI=1:" ***SERIOUSLY ILL***",1:"***DO NOT RESUSCITATE***")
ADGSIL1 ; IHS/ADC/PDW/ENM - SI/DNR LISTING ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
+3 WRITE @IOF,!!!
KILL ^TMP("DGZSIL",$JOB)
+4 WRITE ?10,"PATIENTS CURRENTLY ON SERIOUSLY ILL/DO NOT RESUSCITATE LIST",!!
A ; -- main
+1 DO ZIS
IF POP
DO Q
QUIT
+2 IF $DATA(IO("Q"))
DO QUE
DO Q
QUIT
+3 DO LW
DO WRT
DO Q
QUIT
+4 ;
START ; -- queued output driver
+1 KILL ^TMP("DGZSIL",$JOB)
+2 DO LW
DO WRT
DO Q
QUIT
+3 ;
LW ; -- loop inpatients
+1 NEW WD,DFN,WARD,NAME,TS,PR,CON,CDT,UTL,N,X
+2 SET WARD=""
FOR
SET WARD=$ORDER(^DPT("CN",WARD))
IF WARD=""
QUIT
Begin DoDot:1
+3 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WARD,DFN))
IF 'DFN
QUIT
DO VAR
End DoDot:1
+4 QUIT
+5 ;
VAR ;
+1 IF '$DATA(^DPT(DFN,"DAC"))
QUIT
IF $PIECE(^("DAC"),U)=""
QUIT
SET N=^("DAC")
+2 SET NAME=$PIECE($GET(^DPT(DFN,0)),U)
SET TS=$GET(^(.103))
SET PR=$GET(^(.104))
+3 SET WD=$ORDER(^DIC(42,"B",WARD,0))
SET CON=$PIECE(N,U)
SET CDT=$PIECE(N,U,2)
+4 SET UTL=$$AGE_U_TS_U_PR_U_$$HRCN^ADGF_U_WARD_U_CDT
+5 IF CON="S"!(CON="B")
SET ^TMP("DGZSIL",$JOB,1,NAME,DFN)=UTL
+6 IF CON="D"!(CON="B")
SET ^TMP("DGZSIL",$JOB,2,NAME,DFN)=UTL
+7 QUIT
+8 ;
WRT ; -- loop utl
+1 NEW WD,DFN,WARD,NAME,TS,PR,CON,CDT,UTL,N,X
+2 USE IO
DO HD
SET SI=0
FOR
SET SI=$ORDER(^TMP("DGZSIL",$JOB,SI))
IF 'SI
QUIT
Begin DoDot:1
+3 WRITE !!?28,$$HD1,!
+4 SET NAME=""
FOR
SET NAME=$ORDER(^TMP("DGZSIL",$JOB,SI,NAME))
IF NAME=""
QUIT
Begin DoDot:2
+5 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("DGZSIL",$JOB,SI,NAME,DFN))
IF 'DFN
QUIT
DO 1
IF $DATA(DIRUT)
QUIT
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
1 SET N=^TMP("DGZSIL",$JOB,SI,NAME,DFN)
+1 WRITE !,$EXTRACT(NAME,1,20),?23,$PIECE(N,U,4)
+2 WRITE ?32,$EXTRACT($PIECE($GET(^VA(200,+$PIECE(N,U,3),0)),U),1,12)
+3 WRITE ?48,$PIECE(N,U),?57,$PIECE(N,U,5),?63,$EXTRACT($GET(^DIC(45.7,+$PIECE(N,U,2),0)),1,3)
+4 WRITE ?69,$EXTRACT($PIECE(N,U,6),4,5)_"/"_$EXTRACT($PIECE(N,U,6),6,7)_"/"_$EXTRACT($PIECE(N,U,6),2,3)
+5 IF $Y>(IOSL-7)
DO NPG
+6 QUIT
+7 ;
HD ; -- heading
+1 IF IOST["C-"
WRITE @IOF
+2 WRITE ?11,"*****Confidential Patient Data Covered by Privacy Act*****"
+3 WRITE !!?22,"SERIOUSLY ILL/DO NOT RESUSCITATE LIST",!
+4 WRITE ?34,"for ",$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3),!!
+5 WRITE !,"Patient Name",?23,"Chart #",?32,"Provider",?48,"Age"
+6 WRITE ?57,"WD",?63,"SRV",?69,"Entered"
QUIT
+7 ;
ZIS ; -- device selection
+1 SET %ZIS="PQ"
DO ^%ZIS
QUIT
+2 ;
QUE ; -- queued output
+1 SET ZTRTN="START^ADGSIL1"
SET ZTDESC="SI/DNR LIST"
DO ^%ZTLOAD
QUIT
+2 ;
NPG ; -- end of page
+1 IF IOST'?1"C-".E
DO HD
QUIT
+2 KILL DIR
SET DIR(0)="E"
DO ^DIR
IF '$DATA(DIRUT)
DO HD
QUIT
+3 ;
Q ; -- cleanup
+1 IF IOST?1"C-".E
DO PRTOPT^ADGVAR
+2 WRITE @IOF
DO ^%ZISC
DO HOME^%ZIS
KILL ZTSK,IO("Q")
QUIT
+3 ;
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=^UTILITY("DIQ1",$JOB,9000001,DFN,1102.98)
KILL ^UTILITY("DIQ1",$JOB)
+4 QUIT X
+5 ;
HD1() ; -- heading
+1 QUIT $SELECT(SI=1:" ***SERIOUSLY ILL***",1:"***DO NOT RESUSCITATE***")
