SDROUT1.m

SDROUT1 ;MAN/GRR - ROUTING SLIPS ;3/5/92  13:21

 ;;5.3;Scheduling;**3,377,1015**;Aug 13, 1993;Build 21

AO S HGDT=GDATE,SDHSC=SC F SDI=3,4,5 I $P(^DPT(DFN,"S",HGDT,0),"^",SDI)]"" S GDATE=$P(^(0),"^",SDI),SC=$S(SDI=3:"LAB",SDI=4:"XRAY",1:"EKG") D OSET

 S GDATE=HGDT,SC=SDHSC K HGDT,SDHSC Q

OSET ;

 I ORDER="" S ^UTILITY($J,NAME,DFN,GDATE,SC)="" Q

 I ORDER=1 S ^UTILITY($J," "_TDO,DFN,GDATE,SC)="" Q

 S ^UTILITY($J,"B",DFN,GDATE)=SC Q

LIN2 S SDM=M F SDI=3,4,5 I $P(^DPT(J,"S",SDM,0),"^",SDI)]"" S (X,M)=$P(^(0),"^",SDI) D TM^SDROUT0 S Y=M D DTS^SDUTL W !,Y,?11,$J(X,8),?20,$S(SDI=3:"LAB",SDI=4:"XRAY",1:"EKG") Q:($Y>(IOSL-1))

 S M=SDM K SDM,SDI Q

SIN1 S ORDER="",SDCNT=0

SIN Q:SDIQ=1  S DIC="^DPT(",DIC(0)="AEQM" D ^DIC G:X="^"!(X="") END I Y<0 W !,"PATIENT NOT FOUND" G SIN

 S DFN=+Y D:'$D(DT) DT^SDUTL

EN S VAR="DIV^ORDER^SDX^DFN^SDREP^SDSTART^SDLOC^SDPLSRT",DGPGM="EN1^SDROUT1"

 D ZIS^DGUTQ G:POP END

EN1 ; -- main entry point

 ; required input: as defined in VAR above

 ; optional input:

 ;   SDPARMS("START")        := start date for appts

 ;          ("DO NOT CLOSE") := [1 or 0] if 1 then device will stay open

 ;

 U IO K ^UTILITY($J) S Y=DT D DTS^SDUTL S PRDATE=Y,P=0,GDATE=DT,SDIQ=1,NAME=$P(^DPT(DFN,0),"^",1),J=DFN,ORDER="",APDATE="",SDREP=$S($D(SDREP):SDREP,1:""),SDX=$S($D(SDX):SDX,1:""),SDSTART=$S($D(SDSTART):SDSTART,1:"")

 S SDATE=+$G(SDPARMS("START")) S:'SDATE SDATE=DT

 I '$D(^DPT(DFN,"S")) G NOAP

 S NDATE=$O(^DPT(DFN,"S",SDATE)) I NDATE\1'=SDATE G NOCA

 S Y=DT D DTS^SDUTL S APDATE=Y

 K SDA F GDATE=SDATE:0 S GDATE=$O(^DPT(DFN,"S",GDATE)) Q:GDATE=""!(GDATE\1-SDATE)  I $P(^(GDATE,0),"^",2)="I"!($P(^(0),"^",2)="") D GOT

 G:'$D(SDA) NOCA G GO^SDROUT0

NOCA D HED^SDROUT2,HD^SDROUT2 D:'$D(SDSCCOND) SCCOND^SDROUT2 W !!! D FUT^SDROUT0 W !,@IOF G END

NOAP D HED^SDROUT2,HD^SDROUT2 D:'$D(SDSCCOND) SCCOND^SDROUT2 W !!! D HED2^SDROUT0

 I $D(SDREP),SDREP,SDX'["ALL" S Y=SDSTART D DTS^SDUTL W !!,"DATE PRINTED  : ",Y,!,"DATE REPRINTED: ",PRDATE

 I '$T W !!,"DATE PRINTED: ",PRDATE

 W !,@IOF G END

GOT S SDA="",NAME=$P(^DPT(DFN,0),"^",1),SC=$P(^DPT(DFN,"S",GDATE,0),"^",1),Y=SDATE D DTS^SDUTL S APDATE=Y D AO,SC S ^UTILITY($J,NAME,DFN,GDATE,SC)=$S(V:"** COLLATERAL **",1:"")

 Q

SC I $D(^DPT(DFN,.36)),$D(^DIC(8,+^DPT(DFN,.36),0)),$P(^(0),"^",9)=13 S V=1 Q

 S V=0 F M=0:0 S M=$O(^SC(SC,"S",GDATE,1,M)) Q:M'>0  I $D(^(M,0)),+^(0)=DFN,$P(^(0),"^",9)'["C" S V=$P(^(0),"^",10) Q:V']""  S V=$S($D(^DIC(8,+V,0)):$P(^(0),"^",9)=13,1:0) Q

 Q

END I $D(SDCNT) D:SDCNT>1 END1

 W:'$G(SDPARMS("DO NOT CLOSE")) !

 K %,%DT,%I,ADDR,ALL,APDATE,DFN,DGMT,DIC,DIV,G,GDATE,H,I,J,K,L,LL,M,NAME,NDATE,ORD,ORDER,P,POP,PRDATE

 K SC,SDA,SDATE,SDCNT,SDI,SDI1,SDIQ,SDM,SDREP,SDSP,SDSTART,SDVA,SDX,SDX1,SSN,SZ,TDO,X,X1,Y,ZIP,ZX,VAR,C,V,SDEF,A,SD,SCN,SDTD,SDSCCOND

 D:'$G(SDPARMS("DO NOT CLOSE")) CLOSE^DGUTQ

 Q

 ;

END1 W !!?2,"***FACILITY: ",$S($D(^DG(40.8,+DIV,0)):$P(^(0),"^",1),1:$P($$SITE^VASITE,U,2)),?48," PRINTED: " D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") W Y

 W !!!?25,"ROUTING SLIPS PRINTED FOR ",!?32 S Y=SDATE X ^DD("DD") W Y,!!!!?20,"TOTAL NUMBER OF ROUTING SLIPS PRINTED: ",SDCNT Q

 ;Parameters For Reprint

REP S SDREP=1 G:SDX["ALL" ALL S %DT("A")="REPRINT ADD-ONS THAT WERE RUN ON WHAT DATE: ",%DT="AEX" D ^%DT K %DT("A") I Y<1 S POP=1 Q

 S SDSTART=Y Q

ALL W !,"ENTER ",$S(ORDER=1:"TERMINAL DIGIT",ORDER=2:"CLINIC NAME",ORDER=3:"PHYSICAL LOCATION",1:"PATIENT NAME")," TO BEGIN REPRINT FROM: " R X:DTIME I X["?" D HELP G ALL

 I "^"[X S POP=1 Q

 I ORDER=1,X'?4N W !,*7,"MUST BE 4 NUMERICS" G ALL

 S SDSTART=X Q

DQ S ZTREQ="@" G EN1

HELP W !!,"THE REPRINT WILL BEGIN PRINTING AT THE ",$S(ORDER=1:"TERMINAL DIGIT",ORDER=2:"CLINIC NAME",ORDER=3:"PHYSICAL LOCATION",1:"PATIENT NAME")," YOU SPECIFY",!

 W "TERMINAL DIGITS MUST BE ENTERED IN TERMINAL DIGIT ORDER",!,"I.E., LAST TWO DIGITS OF SSN PRECEDING THE SIXTH AND SEVENTH DIGITS",! Q

SDROUT1   ;MAN/GRR - ROUTING SLIPS ;3/5/92  13:21

 +1       ;;5.3;Scheduling;**3,377,1015**;Aug 13, 1993;Build 21

AO         SET HGDT=GDATE

           SET SDHSC=SC

           FOR SDI=3,4,5

               IF $PIECE(^DPT(DFN,"S",HGDT,0),"^",SDI)]""

                   SET GDATE=$PIECE(^(0),"^",SDI)

                   SET SC=$SELECT(SDI=3:"LAB",SDI=4:"XRAY",1:"EKG")

                   DO OSET

 +1        SET GDATE=HGDT

           SET SC=SDHSC

           KILL HGDT,SDHSC

           QUIT 

OSET      ;

 +1        IF ORDER=""

               SET ^UTILITY($JOB,NAME,DFN,GDATE,SC)=""

               QUIT 

 +2        IF ORDER=1

               SET ^UTILITY($JOB," "_TDO,DFN,GDATE,SC)=""

               QUIT 

 +3        SET ^UTILITY($JOB,"B",DFN,GDATE)=SC

           QUIT 

LIN2       SET SDM=M

           FOR SDI=3,4,5

               IF $PIECE(^DPT(J,"S",SDM,0),"^",SDI)]""

                   SET (X,M)=$PIECE(^(0),"^",SDI)

                   DO TM^SDROUT0

                   SET Y=M

                   DO DTS^SDUTL

                   WRITE !,Y,?11,$JUSTIFY(X,8),?20,$SELECT(SDI=3:"LAB",SDI=4:"XRAY",1:"EKG")

                   IF ($Y>(IOSL-1))

                       QUIT 

 +1        SET M=SDM

           KILL SDM,SDI

           QUIT 

SIN1       SET ORDER=""

           SET SDCNT=0

SIN        IF SDIQ=1

               QUIT 

           SET DIC="^DPT("

           SET DIC(0)="AEQM"

           DO ^DIC

           IF X="^"!(X="")

               GOTO END

           IF Y<0

               WRITE !,"PATIENT NOT FOUND"

               GOTO SIN

 +1        SET DFN=+Y

           IF '$DATA(DT)

               DO DT^SDUTL

EN         SET VAR="DIV^ORDER^SDX^DFN^SDREP^SDSTART^SDLOC^SDPLSRT"

           SET DGPGM="EN1^SDROUT1"

 +1        DO ZIS^DGUTQ

           IF POP

               GOTO END

EN1       ; -- main entry point

 +1       ; required input: as defined in VAR above

 +2       ; optional input:

 +3       ;   SDPARMS("START")        := start date for appts

 +4       ;          ("DO NOT CLOSE") := [1 or 0] if 1 then device will stay open

 +5       ;

 +6        USE IO

           KILL ^UTILITY($JOB)

           SET Y=DT

           DO DTS^SDUTL

           SET PRDATE=Y

           SET P=0

           SET GDATE=DT

           SET SDIQ=1

           SET NAME=$PIECE(^DPT(DFN,0),"^",1)

           SET J=DFN

           SET ORDER=""

           SET APDATE=""

           SET SDREP=$SELECT($DATA(SDREP):SDREP,1:"")

           SET SDX=$SELECT($DATA(SDX):SDX,1:"")

           SET SDSTART=$SELECT($DATA(SDSTART):SDSTART,1:"")

 +7        SET SDATE=+$GET(SDPARMS("START"))

           IF 'SDATE

               SET SDATE=DT

 +8        IF '$DATA(^DPT(DFN,"S"))

               GOTO NOAP

 +9        SET NDATE=$ORDER(^DPT(DFN,"S",SDATE))

           IF NDATE\1'=SDATE

               GOTO NOCA

 +10       SET Y=DT

           DO DTS^SDUTL

           SET APDATE=Y

 +11       KILL SDA

           FOR GDATE=SDATE:0

               SET GDATE=$ORDER(^DPT(DFN,"S",GDATE))

               IF GDATE=""!(GDATE\1-SDATE)

                   QUIT 

               IF $PIECE(^(GDATE,0),"^",2)="I"!($PIECE(^(0),"^",2)="")

                   DO GOT

 +12       IF '$DATA(SDA)

               GOTO NOCA

           GOTO GO^SDROUT0

NOCA       DO HED^SDROUT2

           DO HD^SDROUT2

           IF '$DATA(SDSCCOND)

               DO SCCOND^SDROUT2

           WRITE !!!

           DO FUT^SDROUT0

           WRITE !,@IOF

           GOTO END

NOAP       DO HED^SDROUT2

           DO HD^SDROUT2

           IF '$DATA(SDSCCOND)

               DO SCCOND^SDROUT2

           WRITE !!!

           DO HED2^SDROUT0

 +1        IF $DATA(SDREP)

               IF SDREP

                   IF SDX'["ALL"

                       SET Y=SDSTART

                       DO DTS^SDUTL

                       WRITE !!,"DATE PRINTED  : ",Y,!,"DATE REPRINTED: ",PRDATE

 +2        IF '$TEST

               WRITE !!,"DATE PRINTED: ",PRDATE

 +3        WRITE !,@IOF

           GOTO END

GOT        SET SDA=""

           SET NAME=$PIECE(^DPT(DFN,0),"^",1)

           SET SC=$PIECE(^DPT(DFN,"S",GDATE,0),"^",1)

           SET Y=SDATE

           DO DTS^SDUTL

           SET APDATE=Y

           DO AO

           DO SC

           SET ^UTILITY($JOB,NAME,DFN,GDATE,SC)=$SELECT(V:"** COLLATERAL **",1:"")

 +1        QUIT 

SC         IF $DATA(^DPT(DFN,.36))

               IF $DATA(^DIC(8,+^DPT(DFN,.36),0))

                   IF $PIECE(^(0),"^",9)=13

                       SET V=1

                       QUIT 

 +1        SET V=0

           FOR M=0:0

               SET M=$ORDER(^SC(SC,"S",GDATE,1,M))

               IF M'>0

                   QUIT 

               IF $DATA(^(M,0))

                   IF +^(0)=DFN

                       IF $PIECE(^(0),"^",9)'["C"

                           SET V=$PIECE(^(0),"^",10)

                           IF V']""

                               QUIT 

                           SET V=$SELECT($DATA(^DIC(8,+V,0)):$PIECE(^(0),"^",9)=13,1:0)

                           QUIT 

 +2        QUIT 

END        IF $DATA(SDCNT)

               IF SDCNT>1

                   DO END1

 +1        IF '$GET(SDPARMS("DO NOT CLOSE"))

               WRITE !

 +2        KILL %,%DT,%I,ADDR,ALL,APDATE,DFN,DGMT,DIC,DIV,G,GDATE,H,I,J,K,L,LL,M,NAME,NDATE,ORD,ORDER,P,POP,PRDATE

 +3        KILL SC,SDA,SDATE,SDCNT,SDI,SDI1,SDIQ,SDM,SDREP,SDSP,SDSTART,SDVA,SDX,SDX1,SSN,SZ,TDO,X,X1,Y,ZIP,ZX,VAR,C,V,SDEF,A,SD,SCN,SDTD,SDSCCOND

 +4        IF '$GET(SDPARMS("DO NOT CLOSE"))

               DO CLOSE^DGUTQ

 +5        QUIT 

 +6       ;

END1       WRITE !!?2,"***FACILITY: ",$SELECT($DATA(^DG(40.8,+DIV,0)):$PIECE(^(0),"^",1),1:$PIECE($$SITE^VASITE,U,2)),?48," PRINTED: "

           DO NOW^%DTC

           SET Y=$EXTRACT(%,1,12)

           XECUTE ^DD("DD")

           WRITE Y

 +1        WRITE !!!?25,"ROUTING SLIPS PRINTED FOR ",!?32

           SET Y=SDATE

           XECUTE ^DD("DD")

           WRITE Y,!!!!?20,"TOTAL NUMBER OF ROUTING SLIPS PRINTED: ",SDCNT

           QUIT 

 +2       ;Parameters For Reprint

REP        SET SDREP=1

           IF SDX["ALL"

               GOTO ALL

           SET %DT("A")="REPRINT ADD-ONS THAT WERE RUN ON WHAT DATE: "

           SET %DT="AEX"

           DO ^%DT

           KILL %DT("A")

           IF Y<1

               SET POP=1

               QUIT 

 +1        SET SDSTART=Y

           QUIT 

ALL        WRITE !,"ENTER ",$SELECT(ORDER=1:"TERMINAL DIGIT",ORDER=2:"CLINIC NAME",ORDER=3:"PHYSICAL LOCATION",1:"PATIENT NAME")," TO BEGIN REPRINT FROM: "

           READ X:DTIME

           IF X["?"

               DO HELP

               GOTO ALL

 +1        IF "^"[X

               SET POP=1

               QUIT 

 +2        IF ORDER=1

               IF X'?4N

                   WRITE !,*7,"MUST BE 4 NUMERICS"

                   GOTO ALL

 +3        SET SDSTART=X

           QUIT 

DQ         SET ZTREQ="@"

           GOTO EN1

HELP       WRITE !!,"THE REPRINT WILL BEGIN PRINTING AT THE ",$SELECT(ORDER=1:"TERMINAL DIGIT",ORDER=2:"CLINIC NAME",ORDER=3:"PHYSICAL LOCATION",1:"PATIENT NAME")," YOU SPECIFY",!

 +1        WRITE "TERMINAL DIGITS MUST BE ENTERED IN TERMINAL DIGIT ORDER",!,"I.E., LAST TWO DIGITS OF SSN PRECEDING THE SIXTH AND SEVENTH DIGITS",!

           QUIT