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

Last change on this file since 1796 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.7 KB
Line 
1SDROUT1 ;MAN/GRR - ROUTING SLIPS ;3/5/92 13:21
2 ;;5.3;Scheduling;**3,377**;Aug 13, 1993
3AO 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
4 S GDATE=HGDT,SC=SDHSC K HGDT,SDHSC Q
5OSET ;
6 I ORDER="" S ^UTILITY($J,NAME,DFN,GDATE,SC)="" Q
7 I ORDER=1 S ^UTILITY($J," "_TDO,DFN,GDATE,SC)="" Q
8 S ^UTILITY($J,"B",DFN,GDATE)=SC Q
9LIN2 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))
10 S M=SDM K SDM,SDI Q
11SIN1 S ORDER="",SDCNT=0
12SIN Q:SDIQ=1 S DIC="^DPT(",DIC(0)="AEQM" D ^DIC G:X="^"!(X="") END I Y<0 W !,"PATIENT NOT FOUND" G SIN
13 S DFN=+Y D:'$D(DT) DT^SDUTL
14EN S VAR="DIV^ORDER^SDX^DFN^SDREP^SDSTART^SDLOC^SDPLSRT",DGPGM="EN1^SDROUT1"
15 D ZIS^DGUTQ G:POP END
16EN1 ; -- main entry point
17 ; required input: as defined in VAR above
18 ; optional input:
19 ; SDPARMS("START") := start date for appts
20 ; ("DO NOT CLOSE") := [1 or 0] if 1 then device will stay open
21 ;
22 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:"")
23 S SDATE=+$G(SDPARMS("START")) S:'SDATE SDATE=DT
24 I '$D(^DPT(DFN,"S")) G NOAP
25 S NDATE=$O(^DPT(DFN,"S",SDATE)) I NDATE\1'=SDATE G NOCA
26 S Y=DT D DTS^SDUTL S APDATE=Y
27 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
28 G:'$D(SDA) NOCA G GO^SDROUT0
29NOCA D HED^SDROUT2,HD^SDROUT2 D:'$D(SDSCCOND) SCCOND^SDROUT2 W !!! D FUT^SDROUT0 W !,@IOF G END
30NOAP D HED^SDROUT2,HD^SDROUT2 D:'$D(SDSCCOND) SCCOND^SDROUT2 W !!! D HED2^SDROUT0
31 I $D(SDREP),SDREP,SDX'["ALL" S Y=SDSTART D DTS^SDUTL W !!,"DATE PRINTED : ",Y,!,"DATE REPRINTED: ",PRDATE
32 I '$T W !!,"DATE PRINTED: ",PRDATE
33 W !,@IOF G END
34GOT 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:"")
35 Q
36SC I $D(^DPT(DFN,.36)),$D(^DIC(8,+^DPT(DFN,.36),0)),$P(^(0),"^",9)=13 S V=1 Q
37 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
38 Q
39END I $D(SDCNT) D:SDCNT>1 END1
40 W:'$G(SDPARMS("DO NOT CLOSE")) !
41 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
42 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
43 D:'$G(SDPARMS("DO NOT CLOSE")) CLOSE^DGUTQ
44 Q
45 ;
46END1 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
47 W !!!?25,"ROUTING SLIPS PRINTED FOR ",!?32 S Y=SDATE X ^DD("DD") W Y,!!!!?20,"TOTAL NUMBER OF ROUTING SLIPS PRINTED: ",SDCNT Q
48 ;Parameters For Reprint
49REP 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
50 S SDSTART=Y Q
51ALL 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
52 I "^"[X S POP=1 Q
53 I ORDER=1,X'?4N W !,*7,"MUST BE 4 NUMERICS" G ALL
54 S SDSTART=X Q
55DQ S ZTREQ="@" G EN1
56HELP 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",!
57 W "TERMINAL DIGITS MUST BE ENTERED IN TERMINAL DIGIT ORDER",!,"I.E., LAST TWO DIGITS OF SSN PRECEDING THE SIXTH AND SEVENTH DIGITS",! Q
Note: See TracBrowser for help on using the repository browser.