source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDROUT1.m@ 1641

SDROUT1 ;MAN/GRR - ROUTING SLIPS ;3/5/92  13:21
 ;;5.3;Scheduling;**3,377**;Aug 13, 1993
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