- SCRPW7 ;RENO/KEITH - Patient Encounter List ; 15 Jul 98 02:38PM
- ;;5.3;Scheduling;**139,144,466,1015**;AUG 13, 1993;Build 21
- ASK N DIC,%DT D TITL^SCRPW50("Patient Encounter List")
- W ! S DIC="^DPT(",DIC(0)="AZEMQ" D ^DIC G:$D(DTOUT)!$D(DUOUT) EXIT G:Y'>0 EXIT S SDPT=$P(Y,U),SDPTNA=$P(Y,U,2),SDPTSN=$P(Y(0),U,9)
- I '$D(^SCE("ADFN",SDPT)) W !!,$C(7),"This patient has no encounters on file.",! H 3 G ASK
- D SUBT^SCRPW50("*** Date Range Selection ***")
- FDT W ! S %DT="AEPX",%DT("A")="Beginning date: FIRST// ",%DT(0)="-TODAY" D ^%DT G:X=U!($D(DTOUT)) EXIT I X="" S Y=$O(^SCE("ADFN",SDPT,0)),(Y,SDBDT)=$P(Y,".") X ^DD("DD") W " ",Y S SDPBDA=Y G LDT
- G:Y<1 FDT S SDBDT=Y X ^DD("DD") W " ",Y S SDPBDA=Y
- LDT W ! S %DT("A")="Ending date: LAST// " D ^%DT G:X=U!($D(DTOUT)) EXIT I X="" S (Y,SDEDT)=DT X ^DD("DD") W " ",Y S SDPEDA=Y W ! G QUE
- I Y<SDBDT W !!,$C(7),"Ending date must be after beginning date!",! G LDT
- G:Y<1 LDT S SDEDT=Y X ^DD("DD") W " ",Y S SDPEDA=Y
- QUE S SDEDT=SDEDT+.9999 N ZTSAVE F X="SDPT","SDPTNA","SDPTSN","SDBDT","SDPBDA","SDEDT","SDPEDA" S ZTSAVE(X)=""
- W ! D EN^XUTMDEVQ("PEL^SCRPW7","Patient Encounter List",.ZTSAVE) G ASK
- ;
- PEL S SDPAGE=1,SDLINE="",$P(SDLINE,"=",(IOM+1))="",SDOUT=0,SDP=$S($E(IOST)="C":6,1:4),SDDT=SDEDT D:$E(IOST)="C" DISP0^SCRPW23 D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW="Date printed: "_$P(Y,":",1,2),SDCT=0
- D HDR Q:SDOUT F S SDDT=$O(^SCE("ADFN",SDPT,SDDT),-1) Q:'SDDT!SDOUT!(SDDT<SDBDT) S SDOE=0 F S SDOE=$O(^SCE("ADFN",SDPT,SDDT,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE) D:$L(SDOE0) DISP S SDCT=SDCT+1
- I 'SDCT S X="No encounters found within this date range!" W !!?(IOM-$L(X)\2),X,!
- END I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR
- EXIT D END^SCRPW50 K %,%I,%H,SDBDT,SDPBDA,SDCT,SDEDT,SDPEDA,SDP,SDLINE,SDPAGE,SDDT,SDI,SDL,SDOE,SDOE0,SDOUT,SDPT,SDPNOW,SDPTNA,SDPTSN,SDS,SDS1,SDT,DTOUT,DUOUT,Y,X Q
- ;
- STOP ;Check for stop task request
- S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
- ;
- HDR W:SDP=6!(SDPAGE>1) $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0)
- D STOP Q:SDOUT W SDLINE I SDP=4!(SDPAGE=1) W !?(IOM-32/2),"<*> PATIENT ENCOUNTER LIST <*>",!,SDLINE,!,"Date range: ",SDPBDA," to ",SDPEDA,?(IOM-$L(SDPNOW)),SDPNOW
- W !,"Patient: ",SDPTNA,?40,"SSN: ",SDPTSN,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1
- Q
- ;
- DISP S SDL=$P($G(^SC(+$P(SDOE0,U,4),0)),U),SDT=$P(SDOE0,U,8),SDT=$S(SDT=1:"Appointment",SDT=2:"Stop Code Addition",SDT=3:"Disposition",SDT=4:"Credit Stop Code",1:""),SDS=$P($G(^SD(409.63,+$P(SDOE0,U,12),0)),U)
- S SDS1=$$COTS(SDOE) D:$Y>(IOSL-SDP) WAIT Q:SDOUT S Y=SDDT X ^DD("DD") W !,Y,?30,SDL,!?5,"#",SDOE,?15,SDT,?35,SDS W:$L(SDS1) " - ",SDS1 W ! F SDI=1:1:80 W "-"
- Q
- ;
- WAIT I SDP=4 D HDR Q
- W ! K DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1
- D:Y HDR Q
- ;
- COTS(SDOE) Q:$P(SDOE0,U,6) "Child of enc. #"_$P(SDOE0,U,6)
- I $P(SDOE0,U,4),$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y" Q ""
- Q:"^CHECKED OUT^INPATIENT APPOINTMENT^"'["^"_SDS_"^" "" Q $P($$STX^SCRPW8(SDOE,SDOE0),U,2)
- SCRPW7 ;RENO/KEITH - Patient Encounter List ; 15 Jul 98 02:38PM
- +1 ;;5.3;Scheduling;**139,144,466,1015**;AUG 13, 1993;Build 21
- ASK NEW DIC,%DT
- DO TITL^SCRPW50("Patient Encounter List")
- +1 WRITE !
- SET DIC="^DPT("
- SET DIC(0)="AZEMQ"
- DO ^DIC
- IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO EXIT
- IF Y'>0
- GOTO EXIT
- SET SDPT=$PIECE(Y,U)
- SET SDPTNA=$PIECE(Y,U,2)
- SET SDPTSN=$PIECE(Y(0),U,9)
- +2 IF '$DATA(^SCE("ADFN",SDPT))
- WRITE !!,$CHAR(7),"This patient has no encounters on file.",!
- HANG 3
- GOTO ASK
- +3 DO SUBT^SCRPW50("*** Date Range Selection ***")
- FDT WRITE !
- SET %DT="AEPX"
- SET %DT("A")="Beginning date: FIRST// "
- SET %DT(0)="-TODAY"
- DO ^%DT
- IF X=U!($DATA(DTOUT))
- GOTO EXIT
- IF X=""
- SET Y=$ORDER(^SCE("ADFN",SDPT,0))
- SET (Y,SDBDT)=$PIECE(Y,".")
- XECUTE ^DD("DD")
- WRITE " ",Y
- SET SDPBDA=Y
- GOTO LDT
- +1 IF Y<1
- GOTO FDT
- SET SDBDT=Y
- XECUTE ^DD("DD")
- WRITE " ",Y
- SET SDPBDA=Y
- LDT WRITE !
- SET %DT("A")="Ending date: LAST// "
- DO ^%DT
- IF X=U!($DATA(DTOUT))
- GOTO EXIT
- IF X=""
- SET (Y,SDEDT)=DT
- XECUTE ^DD("DD")
- WRITE " ",Y
- SET SDPEDA=Y
- WRITE !
- GOTO QUE
- +1 IF Y<SDBDT
- WRITE !!,$CHAR(7),"Ending date must be after beginning date!",!
- GOTO LDT
- +2 IF Y<1
- GOTO LDT
- SET SDEDT=Y
- XECUTE ^DD("DD")
- WRITE " ",Y
- SET SDPEDA=Y
- QUE SET SDEDT=SDEDT+.9999
- NEW ZTSAVE
- FOR X="SDPT","SDPTNA","SDPTSN","SDBDT","SDPBDA","SDEDT","SDPEDA"
- SET ZTSAVE(X)=""
- +1 WRITE !
- DO EN^XUTMDEVQ("PEL^SCRPW7","Patient Encounter List",.ZTSAVE)
- GOTO ASK
- +2 ;
- PEL SET SDPAGE=1
- SET SDLINE=""
- SET $PIECE(SDLINE,"=",(IOM+1))=""
- SET SDOUT=0
- SET SDP=$SELECT($EXTRACT(IOST)="C":6,1:4)
- SET SDDT=SDEDT
- IF $EXTRACT(IOST)="C"
- DO DISP0^SCRPW23
- DO NOW^%DTC
- SET Y=%
- XECUTE ^DD("DD")
- SET SDPNOW="Date printed: "_$PIECE(Y,":",1,2)
- SET SDCT=0
- +1 DO HDR
- IF SDOUT
- QUIT
- FOR
- SET SDDT=$ORDER(^SCE("ADFN",SDPT,SDDT),-1)
- IF 'SDDT!SDOUT!(SDDT<SDBDT)
- QUIT
- SET SDOE=0
- FOR
- SET SDOE=$ORDER(^SCE("ADFN",SDPT,SDDT,SDOE))
- IF 'SDOE!SDOUT
- QUIT
- SET SDOE0=$$GETOE^SDOE(SDOE)
- IF $LENGTH(SDOE0)
- DO DISP
- SET SDCT=SDCT+1
- +2 IF 'SDCT
- SET X="No encounters found within this date range!"
- WRITE !!?(IOM-$LENGTH(X)\2),X,!
- END IF $EXTRACT(IOST)="C"
- IF 'SDOUT
- NEW DIR
- SET DIR(0)="E"
- DO ^DIR
- EXIT DO END^SCRPW50
- KILL %,%I,%H,SDBDT,SDPBDA,SDCT,SDEDT,SDPEDA,SDP,SDLINE,SDPAGE,SDDT,SDI,SDL,SDOE,SDOE0,SDOUT,SDPT,SDPNOW,SDPTNA,SDPTSN,SDS,SDS1,SDT,DTOUT,DUOUT,Y,X
- QUIT
- +1 ;
- STOP ;Check for stop task request
- +1 IF $GET(ZTQUEUED)
- SET (SDOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)
- QUIT
- +2 ;
- HDR IF SDP=6!(SDPAGE>1)
- WRITE $$XY^SCRPW50(IOF,1,0)
- IF $X
- WRITE $$XY^SCRPW50("",0,0)
- +1 DO STOP
- IF SDOUT
- QUIT
- WRITE SDLINE
- IF SDP=4!(SDPAGE=1)
- WRITE !?(IOM-32/2),"<*> PATIENT ENCOUNTER LIST <*>",!,SDLINE,!,"Date range: ",SDPBDA," to ",SDPEDA,?(IOM-$LENGTH(SDPNOW)),SDPNOW
- +2 WRITE !,"Patient: ",SDPTNA,?40,"SSN: ",SDPTSN,?(IOM-6-$LENGTH(SDPAGE)),"Page: ",SDPAGE,!,SDLINE
- SET SDPAGE=SDPAGE+1
- +3 QUIT
- +4 ;
- DISP SET SDL=$PIECE($GET(^SC(+$PIECE(SDOE0,U,4),0)),U)
- SET SDT=$PIECE(SDOE0,U,8)
- SET SDT=$SELECT(SDT=1:"Appointment",SDT=2:"Stop Code Addition",SDT=3:"Disposition",SDT=4:"Credit Stop Code",1:"")
- SET SDS=$PIECE($GET(^SD(409.63,+$PIECE(SDOE0,U,12),0)),U)
- +1 SET SDS1=$$COTS(SDOE)
- IF $Y>(IOSL-SDP)
- DO WAIT
- IF SDOUT
- QUIT
- SET Y=SDDT
- XECUTE ^DD("DD")
- WRITE !,Y,?30,SDL,!?5,"#",SDOE,?15,SDT,?35,SDS
- IF $LENGTH(SDS1)
- WRITE " - ",SDS1
- WRITE !
- FOR SDI=1:1:80
- WRITE "-"
- +2 QUIT
- +3 ;
- WAIT IF SDP=4
- DO HDR
- QUIT
- +1 WRITE !
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- SET SDOUT=Y'=1
- +2 IF Y
- DO HDR
- QUIT
- +3 ;
- COTS(SDOE) IF $PIECE(SDOE0,U,6)
- QUIT "Child of enc. #"_$PIECE(SDOE0,U,6)
- +1 IF $PIECE(SDOE0,U,4)
- IF $PIECE($GET(^SC($PIECE(SDOE0,U,4),0)),U,17)="Y"
- QUIT ""
- +2 IF "^CHECKED OUT^INPATIENT APPOINTMENT^"'["^"_SDS_"^"
- QUIT ""
- QUIT $PIECE($$STX^SCRPW8(SDOE,SDOE0),U,2)
