- 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
