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
