ADGDSN ; IHS/ADC/PDW/ENM - PATIENTS NOT RELEASED FROM DAY SURGERY ; [ 01/05/2004 11:45 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;**2**;MAR 25, 1999
;
;***> get date range and device
W !!?10,"PRINT LIST OF PATIENTS NOT RELEASED FROM DAY SURGERY"
DATE S %DT="AEQ",%DT("A")="Beginning date: ",X="" D ^%DT
G END:Y=-1 S DGBDT=Y
DATE2 S %DT="AEQ",%DT("A")="Ending date: ",X="" D ^%DT G DATE:Y=-1 S DGEDT=Y
I DGEDT<DGBDT W *7,!!?5,"Ending date MUST NOT be before beginning date",! G DATE2
;IHS/ITSC/WAR 12/16/03 added .2400 to include todays patients
;I DGEDT'<DT S X1=DT,X2=-1 D C^%DTC S DGEDT=X
I DGEDT'<(DT+.2400) S X1=DT,X2=-1 D C^%DTC S DGEDT=X
;
W !! S %ZIS="PQ" D ^%ZIS G END:POP,QUE:$D(IO("Q")) U IO G CALC
QUE K IO("Q") S ZTRTN="CALC^ADGDSN",ZTDESC="DS NOT RELEASED"
;F DGI="DGBDT","DGEDT" S ZTSAVE("DGI")=""
F DGI="DGBDT","DGEDT" S ZTSAVE(DGI)="" ;IHS/DSD/ENM 06/14/99
D ^%ZTLOAD D ^%ZISC K ZTSK
END K DGBED,DGEDT D HOME^%ZIS Q
;
;
CALC ;***> calculate patients not released; screen out no-shows & cancels
S DGDT=DGBDT-.0001,DGEDT=DGEDT_.2400 K ^TMP("DGZDSN",$J)
A1 S DGDT=$O(^ADGDS("AA",DGDT)) G PRNT:DGDT="",PRNT:DGDT>DGEDT S DFN=0
A2 S DFN=$O(^ADGDS("AA",DGDT,DFN)) G A1:DFN="" S DGN=0
A3 S DGN=$O(^ADGDS("AA",DGDT,DFN,DGN)) G A2:DGN=""
G A3:'$D(^ADGDS(DFN,"DS",DGN,0))
G A4:'$D(^ADGDS(DFN,"DS",DGN,2)) S DGSTR=^(2)
G A3:$P(DGSTR,U)'="",A3:$P(DGSTR,U,3)="Y",A3:$P(DGSTR,U,4)="Y"
A4 S ^TMP("DGZDSN",$J,DGDT,DFN)="" G A3
;
PRNT ;***> print list
S DGDT=0,DGSTOP="",DGPAGE=""
S DGLIN="",$P(DGLIN,"=",80)=""
S DGFAC=$P(^DIC(4,DUZ(2),0),U),DGDUZ=$P(^VA(200,DUZ,0),U,2)
D HEAD
PR1 S DGDT=$O(^TMP("DGZDSN",$J,DGDT)) G END1:DGDT="" S DFN=0
PR2 S DFN=$O(^TMP("DGZDSN",$J,DGDT,DFN)) G PR1:DFN=""
S DGT=$P(DGDT,".",2),DGT=$E(DGT_"000",1,4)
S X=$P(DGDT,"."),X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)_" at "_DGT
W !?3,$P(^DPT(DFN,0),U)
W:$D(^AUPNPAT(DFN,41,DUZ(2),0)) ?30,$J($P(^(0),U,2),7) W ?50,X
D NEWPG:($Y>(IOSL-6)) G END2:DGSTOP=U G PR2
;
;
END1 ;***> eoj
I IOST["C-" D PRTOPT^ADGVAR
END2 W @IOF D KILL^ADGUTIL
D ^%ZISC K ^TMP("DGZDSN",$J) Q
;
;
NEWPG ;***> subrtn for end of page control
I IOST'?1"C-".E D HEAD S DGSTOP="" Q
I DGPAGE>0 K DIR S DIR(0)="E" D ^DIR S DGSTOP=X
I DGSTOP'=U D HEAD
Q
;
HEAD ;***> subrtn to print heading
I (IOST["C-")!(DGPAGE>0) W @IOF
S DGPAGE=DGPAGE+1
W ?11,"*****Confidential Patient Data Covered by Privacy Act*****"
W !,DGDUZ,?80-$L(DGFAC)\2,DGFAC
W ! D TIME^ADGUTIL W ?23,"DAY SURGERY PATIENTS NOT RELEASED"
W !!!?3,"PATIENT NAME",?30,"CHART #",?50,"SURGERY DATE/TIME"
W !,DGLIN,!! Q
ADGDSN ; IHS/ADC/PDW/ENM - PATIENTS NOT RELEASED FROM DAY SURGERY ; [ 01/05/2004 11:45 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**2**;MAR 25, 1999
+2 ;
+3 ;***> get date range and device
+4 WRITE !!?10,"PRINT LIST OF PATIENTS NOT RELEASED FROM DAY SURGERY"
DATE SET %DT="AEQ"
SET %DT("A")="Beginning date: "
SET X=""
DO ^%DT
+1 IF Y=-1
GOTO END
SET DGBDT=Y
DATE2 SET %DT="AEQ"
SET %DT("A")="Ending date: "
SET X=""
DO ^%DT
IF Y=-1
GOTO DATE
SET DGEDT=Y
+1 IF DGEDT<DGBDT
WRITE *7,!!?5,"Ending date MUST NOT be before beginning date",!
GOTO DATE2
+2 ;IHS/ITSC/WAR 12/16/03 added .2400 to include todays patients
+3 ;I DGEDT'<DT S X1=DT,X2=-1 D C^%DTC S DGEDT=X
+4 IF DGEDT'<(DT+.2400)
SET X1=DT
SET X2=-1
DO C^%DTC
SET DGEDT=X
+5 ;
+6 WRITE !!
SET %ZIS="PQ"
DO ^%ZIS
IF POP
GOTO END
IF $DATA(IO("Q"))
GOTO QUE
USE IO
GOTO CALC
QUE KILL IO("Q")
SET ZTRTN="CALC^ADGDSN"
SET ZTDESC="DS NOT RELEASED"
+1 ;F DGI="DGBDT","DGEDT" S ZTSAVE("DGI")=""
+2 ;IHS/DSD/ENM 06/14/99
FOR DGI="DGBDT","DGEDT"
SET ZTSAVE(DGI)=""
+3 DO ^%ZTLOAD
DO ^%ZISC
KILL ZTSK
END KILL DGBED,DGEDT
DO HOME^%ZIS
QUIT
+1 ;
+2 ;
CALC ;***> calculate patients not released; screen out no-shows & cancels
+1 SET DGDT=DGBDT-.0001
SET DGEDT=DGEDT_.2400
KILL ^TMP("DGZDSN",$JOB)
A1 SET DGDT=$ORDER(^ADGDS("AA",DGDT))
IF DGDT=""
GOTO PRNT
IF DGDT>DGEDT
GOTO PRNT
SET DFN=0
A2 SET DFN=$ORDER(^ADGDS("AA",DGDT,DFN))
IF DFN=""
GOTO A1
SET DGN=0
A3 SET DGN=$ORDER(^ADGDS("AA",DGDT,DFN,DGN))
IF DGN=""
GOTO A2
+1 IF '$DATA(^ADGDS(DFN,"DS",DGN,0))
GOTO A3
+2 IF '$DATA(^ADGDS(DFN,"DS",DGN,2))
GOTO A4
SET DGSTR=^(2)
+3 IF $PIECE(DGSTR,U)'=""
GOTO A3
IF $PIECE(DGSTR,U,3)="Y"
GOTO A3
IF $PIECE(DGSTR,U,4)="Y"
GOTO A3
A4 SET ^TMP("DGZDSN",$JOB,DGDT,DFN)=""
GOTO A3
+1 ;
PRNT ;***> print list
+1 SET DGDT=0
SET DGSTOP=""
SET DGPAGE=""
+2 SET DGLIN=""
SET $PIECE(DGLIN,"=",80)=""
+3 SET DGFAC=$PIECE(^DIC(4,DUZ(2),0),U)
SET DGDUZ=$PIECE(^VA(200,DUZ,0),U,2)
+4 DO HEAD
PR1 SET DGDT=$ORDER(^TMP("DGZDSN",$JOB,DGDT))
IF DGDT=""
GOTO END1
SET DFN=0
PR2 SET DFN=$ORDER(^TMP("DGZDSN",$JOB,DGDT,DFN))
IF DFN=""
GOTO PR1
+1 SET DGT=$PIECE(DGDT,".",2)
SET DGT=$EXTRACT(DGT_"000",1,4)
+2 SET X=$PIECE(DGDT,".")
SET X=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)_" at "_DGT
+3 WRITE !?3,$PIECE(^DPT(DFN,0),U)
+4 IF $DATA(^AUPNPAT(DFN,41,DUZ(2),0))
WRITE ?30,$JUSTIFY($PIECE(^(0),U,2),7)
WRITE ?50,X
+5 IF ($Y>(IOSL-6))
DO NEWPG
IF DGSTOP=U
GOTO END2
GOTO PR2
+6 ;
+7 ;
END1 ;***> eoj
+1 IF IOST["C-"
DO PRTOPT^ADGVAR
END2 WRITE @IOF
DO KILL^ADGUTIL
+1 DO ^%ZISC
KILL ^TMP("DGZDSN",$JOB)
QUIT
+2 ;
+3 ;
NEWPG ;***> subrtn for end of page control
+1 IF IOST'?1"C-".E
DO HEAD
SET DGSTOP=""
QUIT
+2 IF DGPAGE>0
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET DGSTOP=X
+3 IF DGSTOP'=U
DO HEAD
+4 QUIT
+5 ;
HEAD ;***> subrtn to print heading
+1 IF (IOST["C-")!(DGPAGE>0)
WRITE @IOF
+2 SET DGPAGE=DGPAGE+1
+3 WRITE ?11,"*****Confidential Patient Data Covered by Privacy Act*****"
+4 WRITE !,DGDUZ,?80-$LENGTH(DGFAC)\2,DGFAC
+5 WRITE !
DO TIME^ADGUTIL
WRITE ?23,"DAY SURGERY PATIENTS NOT RELEASED"
+6 WRITE !!!?3,"PATIENT NAME",?30,"CHART #",?50,"SURGERY DATE/TIME"
+7 WRITE !,DGLIN,!!
QUIT
