- 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
