SDCIAL ;ALB/TMP - INPATIENT APPOINTMENT LIST ; 16 JAN 86
;;5.3;Scheduling;**32,406,1015**;Aug 13, 1993;Build 21
S DIV="",SDTT=0 D DIV^SDUTL I $T S DIC("A")="INPATIENT APPOINTMENT LIST FOR WHICH DIVISION:" D ASK^SDDIV Q:Y<0
RD R !,"FOR WARD (TYPE 'ALL' FOR ALL WARDS): ",X:DTIME Q:"^"[X I X?.E1"?" W !,"ENTER A WARD NAME OR ALL FOR ALL WARDS"
S X=$$UP^XLFSTR(X)
I X="ALL" S SDW=X G RD1
S DIC="^DIC(42,",DIC(0)="EQ"
D ^DIC Q:X=""!(X["^") G:Y<0 RD S SDW=+Y
RD1 D DATE^SDUTL G:POP END I BEGDATE<DT W *7,!,"Start date must be in the future" G RD1
S VAR="DIV^SDW^BEGDATE^ENDDATE",VAL=DIV_"^"_SDW_"^"_BEGDATE_"^"_ENDDATE,PGM="START^SDCIAL"
D ZIS^DGUTQ G:POP END
START K ^UTILITY($J),^TMP($J,"SDAMA301"),^TMP($J,"SDAMA301C") U IO I '$D(DT) D DT^SDUTL
N SDLIST,SDCOUNT S SDCOUNT=0
S (SDEND,SD1)=0,SDTT=$S($E(IOST,1,2)="C-"&(IOSL<66):1,1:0)
I SDW'="ALL" S I=$P(^DIC(42,SDW,0),"^",1) D PT D DFN D WRT Q
S I=0 F S I=$O(^DPT("ACN",I)) Q:I="" D PT
D DFN,WRT
Q
PT ;build patient list
S I2="" F S I2=$O(^DPT("ACN",I,I2)) Q:I2'>0 I $D(^DPT(I2,0)) S SDLIST(I2)=""
Q
DFN ;retrieve appt data for list of patients
I $D(SDLIST)'>1 Q
N SDARRAY,SDDFN,SDWARD,SDAPPT,SDCL,SDLAB,SDXRAY,SDEKG,SDOTHER
S SDARRAY(1)=BEGDATE_";"_ENDDATE,SDARRAY(3)="I;R",SDARRAY("FLDS")="1;2;6;19;20;21",SDARRAY(4)="SDLIST("
S SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY) I SDCOUNT<1 Q
;re-sort output by clinic, then patient
S SDDFN=0 F S SDDFN=$O(^TMP($J,"SDAMA301",SDDFN)) Q:SDDFN="" D
. S SDCL=0 F S SDCL=$O(^TMP($J,"SDAMA301",SDDFN,SDCL)) Q:SDCL="" D
.. M ^TMP($J,"SDAMA301C",SDCL,SDDFN)=^TMP($J,"SDAMA301",SDDFN,SDCL)
I DIV'="" D
. ;remove appts if clinic is not in selected division
. S SDCL=0 F S SDCL=$O(^TMP($J,"SDAMA301C",SDCL)) Q:SDCL="" I $P(^SC(SDCL,0),"^",15)'=DIV K ^TMP($J,"SDAMA301C",SDCL)
;get appt data and add to ^UTILITY
S SDCL=0 F S SDCL=$O(^TMP($J,"SDAMA301C",SDCL)) Q:SDCL="" D
. S SDDFN=0 F S SDDFN=$O(^TMP($J,"SDAMA301C",SDCL,SDDFN)) Q:SDDFN="" D
.. S SDAPPT=0 F S SDAPPT=$O(^TMP($J,"SDAMA301C",SDCL,SDDFN,SDAPPT)) Q:SDAPPT="" D
... S SDWARD=$P($G(^DPT(SDDFN,.1)),"^",1)
... S SDLAB=$P(^TMP($J,"SDAMA301C",SDCL,SDDFN,SDAPPT),"^",21)
... S SDXRAY=$P(^TMP($J,"SDAMA301C",SDCL,SDDFN,SDAPPT),"^",20)
... S SDEKG=$P(^TMP($J,"SDAMA301C",SDCL,SDDFN,SDAPPT),"^",19)
... S SDOTHER=$P($G(^TMP($J,"SDAMA301C",SDCL,SDDFN,SDAPPT,"C")),"^",1)
... ;mimic DPT "S" node, but also add 'other' to end (6th piece) for future use:
... I $G(SDWARD)]"" S ^UTILITY($J,SDWARD,SDAPPT\1,SDDFN,"."_$P(SDAPPT,".",2))=SDCL_"^^"_$G(SDLAB)_"^"_$G(SDXRAY)_"^"_$G(SDEKG)_"^"_$G(SDOTHER)
Q
WRT I SDCOUNT<0 W @IOF,?29,"INPATIENT APPOINTMENT LIST",! X "F A=1:1:IOM W ""-""" W !!,$$SDAPIERR^SDAMUTDT() D END Q
S I="" I $O(^UTILITY($J,I))']"" W @IOF,?29,"INPATIENT APPOINTMENT LIST",! X "F A=1:1:IOM W ""-""" W !!,"NO MATCHES FOUND!" G END
S (SDPG,I)=0 F S I=$O(^UTILITY($J,I)) Q:I=""!(SDEND) D HD Q:SDEND S I2=0 F S I2=$O(^UTILITY($J,I,I2)) Q:I2="" D:($Y+4)>IOSL HD Q:SDEND D APPT Q:SDEND
G END
APPT W:SD2 !! D:($Y+6)>IOSL HD Q:SDEND S Y=I2 D DTS^SDUTL W !,Y S SD2=1
S I3=0 F S I3=$O(^UTILITY($J,I,I2,I3)) Q:I3=""!(SDEND) D:($Y+5)>IOSL HD Q:SDEND W !,?2,$P(^DPT(I3,0),"^",1),?34,$P(^(0),"^",9) S I4=0 F S I4=$O(^UTILITY($J,I,I2,I3,I4)) Q:I4="" D WRTC Q:SDEND
Q
WRTC S SDY=$G(^UTILITY($J,I,I2,I3,I4)) I ($Y+4)>IOSL D HD Q:SDEND W !,?2,$P(^DPT(I3,0),"^",1),?34,$P(^(0),"^",9)," (CONTINUED)"
W !,?5,$P(^SC(+SDY,0),"^",1) S Y=I4,SD2=1 D AT^SDUTL W ?37,$J(Y,8) S SDB=50 F A=3:1:5 S Y="."_$P($P(SDY,"^",A),".",2) D AT^SDUTL W ?SDB,$J(Y,8) S SDB=SDB+10
;comments/other
I $P($G(^UTILITY($J,I,I2,I3,I4)),"^",6)]"" W !,?15,$P(^(I4),"^",6) Q
Q
HD I SD1,SDTT D OUT^SDUTL Q:SDEND
S SDPG=SDPG+1,SD1=1 W !,@IOF,!,?29,"INPATIENT APPOINTMENT LIST",?69,"PAGE: ",SDPG,! S SDOS=(77-$L(I))\2 W ?SDOS,"WARD: ",I S Y=DT D DTS^SDUTL W !,?31,"DATE PRINTED: ",Y,!!
W !!,"APPOINTMENT DATE",!,?2,"PATIENT NAME",?34,"SSN",!,?38,"APPOINT",?52,"LAB",?62,"XRAY",?72,"EKG",!,?5,"CLINIC",?38,"TIME" F A=52:10:72 W ?A,"TIME"
W !,?15,"OTHER INFORMATION",! F A=1:1:80 W "-"
S SD2=0 Q
END S:'$D(IOF) IOF="#" W ! W:'SDTT @IOF K ^TMP($J,"SDAMA301"),^TMP($J,"SDAMA301C"),ALL,DIV,POP,SDT1,%DT,A,BEGDATE,DFN,DIC,DIV,ENDDATE,I,I1,I2,I3,I4,II,SD1,SDB,SDEND,SDOS,SDPG,SDSC,SDTT,SDW,SDXX,SDY,X,Y D CLOSE^DGUTQ,SDIAL^SDKILL Q
SDCIAL ;ALB/TMP - INPATIENT APPOINTMENT LIST ; 16 JAN 86
+1 ;;5.3;Scheduling;**32,406,1015**;Aug 13, 1993;Build 21
+2 SET DIV=""
SET SDTT=0
DO DIV^SDUTL
IF $TEST
SET DIC("A")="INPATIENT APPOINTMENT LIST FOR WHICH DIVISION:"
DO ASK^SDDIV
IF Y<0
QUIT
RD READ !,"FOR WARD (TYPE 'ALL' FOR ALL WARDS): ",X:DTIME
IF "^"[X
QUIT
IF X?.E1"?"
WRITE !,"ENTER A WARD NAME OR ALL FOR ALL WARDS"
+1 SET X=$$UP^XLFSTR(X)
+2 IF X="ALL"
SET SDW=X
GOTO RD1
+3 SET DIC="^DIC(42,"
SET DIC(0)="EQ"
+4 DO ^DIC
IF X=""!(X["^")
QUIT
IF Y<0
GOTO RD
SET SDW=+Y
RD1 DO DATE^SDUTL
IF POP
GOTO END
IF BEGDATE<DT
WRITE *7,!,"Start date must be in the future"
GOTO RD1
+1 SET VAR="DIV^SDW^BEGDATE^ENDDATE"
SET VAL=DIV_"^"_SDW_"^"_BEGDATE_"^"_ENDDATE
SET PGM="START^SDCIAL"
+2 DO ZIS^DGUTQ
IF POP
GOTO END
START KILL ^UTILITY($JOB),^TMP($JOB,"SDAMA301"),^TMP($JOB,"SDAMA301C")
USE IO
IF '$DATA(DT)
DO DT^SDUTL
+1 NEW SDLIST,SDCOUNT
SET SDCOUNT=0
+2 SET (SDEND,SD1)=0
SET SDTT=$SELECT($EXTRACT(IOST,1,2)="C-"&(IOSL<66):1,1:0)
+3 IF SDW'="ALL"
SET I=$PIECE(^DIC(42,SDW,0),"^",1)
DO PT
DO DFN
DO WRT
QUIT
+4 SET I=0
FOR
SET I=$ORDER(^DPT("ACN",I))
IF I=""
QUIT
DO PT
+5 DO DFN
DO WRT
+6 QUIT
PT ;build patient list
+1 SET I2=""
FOR
SET I2=$ORDER(^DPT("ACN",I,I2))
IF I2'>0
QUIT
IF $DATA(^DPT(I2,0))
SET SDLIST(I2)=""
+2 QUIT
DFN ;retrieve appt data for list of patients
+1 IF $DATA(SDLIST)'>1
QUIT
+2 NEW SDARRAY,SDDFN,SDWARD,SDAPPT,SDCL,SDLAB,SDXRAY,SDEKG,SDOTHER
+3 SET SDARRAY(1)=BEGDATE_";"_ENDDATE
SET SDARRAY(3)="I;R"
SET SDARRAY("FLDS")="1;2;6;19;20;21"
SET SDARRAY(4)="SDLIST("
+4 SET SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
IF SDCOUNT<1
QUIT
+5 ;re-sort output by clinic, then patient
+6 SET SDDFN=0
FOR
SET SDDFN=$ORDER(^TMP($JOB,"SDAMA301",SDDFN))
IF SDDFN=""
QUIT
Begin DoDot:1
+7 SET SDCL=0
FOR
SET SDCL=$ORDER(^TMP($JOB,"SDAMA301",SDDFN,SDCL))
IF SDCL=""
QUIT
Begin DoDot:2
+8 MERGE ^TMP($JOB,"SDAMA301C",SDCL,SDDFN)=^TMP($JOB,"SDAMA301",SDDFN,SDCL)
End DoDot:2
End DoDot:1
+9 IF DIV'=""
Begin DoDot:1
+10 ;remove appts if clinic is not in selected division
+11 SET SDCL=0
FOR
SET SDCL=$ORDER(^TMP($JOB,"SDAMA301C",SDCL))
IF SDCL=""
QUIT
IF $PIECE(^SC(SDCL,0),"^",15)'=DIV
KILL ^TMP($JOB,"SDAMA301C",SDCL)
End DoDot:1
+12 ;get appt data and add to ^UTILITY
+13 SET SDCL=0
FOR
SET SDCL=$ORDER(^TMP($JOB,"SDAMA301C",SDCL))
IF SDCL=""
QUIT
Begin DoDot:1
+14 SET SDDFN=0
FOR
SET SDDFN=$ORDER(^TMP($JOB,"SDAMA301C",SDCL,SDDFN))
IF SDDFN=""
QUIT
Begin DoDot:2
+15 SET SDAPPT=0
FOR
SET SDAPPT=$ORDER(^TMP($JOB,"SDAMA301C",SDCL,SDDFN,SDAPPT))
IF SDAPPT=""
QUIT
Begin DoDot:3
+16 SET SDWARD=$PIECE($GET(^DPT(SDDFN,.1)),"^",1)
+17 SET SDLAB=$PIECE(^TMP($JOB,"SDAMA301C",SDCL,SDDFN,SDAPPT),"^",21)
+18 SET SDXRAY=$PIECE(^TMP($JOB,"SDAMA301C",SDCL,SDDFN,SDAPPT),"^",20)
+19 SET SDEKG=$PIECE(^TMP($JOB,"SDAMA301C",SDCL,SDDFN,SDAPPT),"^",19)
+20 SET SDOTHER=$PIECE($GET(^TMP($JOB,"SDAMA301C",SDCL,SDDFN,SDAPPT,"C")),"^",1)
+21 ;mimic DPT "S" node, but also add 'other' to end (6th piece) for future use:
+22 IF $GET(SDWARD)]""
SET ^UTILITY($JOB,SDWARD,SDAPPT\1,SDDFN,"."_$PIECE(SDAPPT,".",2))=SDCL_"^^"_$GET(SDLAB)_"^"_$GET(SDXRAY)_"^"_$GET(SDEKG)_"^"_$GET(SDOTHER)
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
WRT IF SDCOUNT<0
WRITE @IOF,?29,"INPATIENT APPOINTMENT LIST",!
XECUTE "F A=1:1:IOM W ""-"""
WRITE !!,$$SDAPIERR^SDAMUTDT()
DO END
QUIT
+1 SET I=""
IF $ORDER(^UTILITY($JOB,I))']""
WRITE @IOF,?29,"INPATIENT APPOINTMENT LIST",!
XECUTE "F A=1:1:IOM W ""-"""
WRITE !!,"NO MATCHES FOUND!"
GOTO END
+2 SET (SDPG,I)=0
FOR
SET I=$ORDER(^UTILITY($JOB,I))
IF I=""!(SDEND)
QUIT
DO HD
IF SDEND
QUIT
SET I2=0
FOR
SET I2=$ORDER(^UTILITY($JOB,I,I2))
IF I2=""
QUIT
IF ($Y+4)>IOSL
DO HD
IF SDEND
QUIT
DO APPT
IF SDEND
QUIT
+3 GOTO END
APPT IF SD2
WRITE !!
IF ($Y+6)>IOSL
DO HD
IF SDEND
QUIT
SET Y=I2
DO DTS^SDUTL
WRITE !,Y
SET SD2=1
+1 SET I3=0
FOR
SET I3=$ORDER(^UTILITY($JOB,I,I2,I3))
IF I3=""!(SDEND)
QUIT
IF ($Y+5)>IOSL
DO HD
IF SDEND
QUIT
WRITE !,?2,$PIECE(^DPT(I3,0),"^",1),?34,$PIECE(^(0),"^",9)
SET I4=0
FOR
SET I4=$ORDER(^UTILITY($JOB,I,I2,I3,I4))
IF I4=""
QUIT
DO WRTC
IF SDEND
QUIT
+2 QUIT
WRTC SET SDY=$GET(^UTILITY($JOB,I,I2,I3,I4))
IF ($Y+4)>IOSL
DO HD
IF SDEND
QUIT
WRITE !,?2,$PIECE(^DPT(I3,0),"^",1),?34,$PIECE(^(0),"^",9)," (CONTINUED)"
+1 WRITE !,?5,$PIECE(^SC(+SDY,0),"^",1)
SET Y=I4
SET SD2=1
DO AT^SDUTL
WRITE ?37,$JUSTIFY(Y,8)
SET SDB=50
FOR A=3:1:5
SET Y="."_$PIECE($PIECE(SDY,"^",A),".",2)
DO AT^SDUTL
WRITE ?SDB,$JUSTIFY(Y,8)
SET SDB=SDB+10
+2 ;comments/other
+3 IF $PIECE($GET(^UTILITY($JOB,I,I2,I3,I4)),"^",6)]""
WRITE !,?15,$PIECE(^(I4),"^",6)
QUIT
+4 QUIT
HD IF SD1
IF SDTT
DO OUT^SDUTL
IF SDEND
QUIT
+1 SET SDPG=SDPG+1
SET SD1=1
WRITE !,@IOF,!,?29,"INPATIENT APPOINTMENT LIST",?69,"PAGE: ",SDPG,!
SET SDOS=(77-$LENGTH(I))\2
WRITE ?SDOS,"WARD: ",I
SET Y=DT
DO DTS^SDUTL
WRITE !,?31,"DATE PRINTED: ",Y,!!
+2 WRITE !!,"APPOINTMENT DATE",!,?2,"PATIENT NAME",?34,"SSN",!,?38,"APPOINT",?52,"LAB",?62,"XRAY",?72,"EKG",!,?5,"CLINIC",?38,"TIME"
FOR A=52:10:72
WRITE ?A,"TIME"
+3 WRITE !,?15,"OTHER INFORMATION",!
FOR A=1:1:80
WRITE "-"
+4 SET SD2=0
QUIT
END IF '$DATA(IOF)
SET IOF="#"
WRITE !
IF 'SDTT
WRITE @IOF
KILL ^TMP($JOB,"SDAMA301"),^TMP($JOB,"SDAMA301C"),ALL,DIV,POP,SDT1,%DT,A,BEGDATE,DFN,DIC,DIV,ENDDATE,I,I1,I2,I3,I4,II,SD1,SDB,SDEND,SDOS,SDPG,SDSC,SDTT,SDW,SDXX,SDY,X,Y
DO CLOSE^DGUTQ
DO SDIAL^SDKILL
QUIT
