SDROUT0 ;BSN/GRR - ROUTING SLIPS BY CLINIC ;11/12/91 16:07
;;5.3;PIMS;**343,377,1015,1016**;JUN 30, 2012;Build 20
GO S SDCNT=0 D GO1 G:ORDER=2!(ORDER=3) CLIN
F G=0:0 S I=$O(^UTILITY($J,I)) Q:I="" F J=0:0 S J=$O(^UTILITY($J,I,J)) Q:J="" S P=0 D HED^SDROUT2,HD^SDROUT2,CNT F K=0:0 S K=$O(^UTILITY($J,I,J,K)) D:K="" FUT Q:K="" S L=0 F LL=0:0 S L=$O(^UTILITY($J,I,J,K,L)) Q:L="" D LIN,X
W:IOF]"" !,@IOF G END^SDROUT1
CNT S SDCNT=SDCNT+1 Q
X I $P(^UTILITY($J,I,J,K,L),"^")]"" W !,?4,$P(^(L),"^") Q
I $D(^DPT(+J,.36)),$D(^DIC(8,+^DPT(+J,.36),0)),$P(^(0),"^",9)=13 W !,?4,"** COLLATERAL **"
Q
GO1 S I=0 Q:'SDREP!(SDX'["ALL")!(SDSTART="0000") I SDSTART?4N S SDZ=(SDSTART-1)/10000,SDZ=$P(SDZ,".",2),SDZ=SDZ_$E("0000",1,4-$L(SDZ)),I=" "_SDZ K SDZ Q
I '$D(^UTILITY($J,SDSTART)) S I=SDSTART Q
S SDZ=$A($E(SDSTART,$L(SDSTART))),I=$E(SDSTART,1,$L(SDSTART)-1)_$C(SDZ-1) K SDZ Q
GOT S DFN=$P(^SC(SC,"S",GDATE,1,L,0),"^") S POP=1 D CKP Q:POP
S NAME=$P(^DPT(DFN,0),"^"),TDO=$P(^(0),"^",9),TDO=$E(TDO,8,9)_$E(TDO,6,7)
D ^SDROUT1 G TDO:ORDER=1,CLO:ORDER=2,PLOC:ORDER=3 D COL S ^UTILITY($J,NAME,DFN,GDATE,SC)=$S(V:"** COLLATERAL **",1:"") K V
Q
TDO D COL S ^UTILITY($J," "_TDO,DFN,GDATE,SC)=$S(V:"** COLLATERAL **",1:"") Q
CLO D COL S SCN=$S($D(^SC(SC,0)):$P(^(0),"^"),1:SC),^UTILITY($J,"A",SCN," "_TDO,DFN)=SC_$S(V:"^** COLLATERAL **",1:""),^UTILITY($J,"B",DFN,GDATE)=SC K V Q
PLOC I VAUTC=0,'$D(VAUTC(SC)) Q
D COL
S SDLOC=$P($G(^SC(SC,0)),"^",11) I SDLOC="" S SDLOC="NOT DEFINED"
I SDLOC'=SDPLSRT,SDPLSRT'="ALL" Q
S ^UTILITY($J,"A",SDLOC," "_TDO,DFN)=SC_$S(V:"** COLLATERAL **",1:"")
S ^UTILITY($J,"B",DFN,GDATE)=SC
K V
Q
COL S V=0 I $P(^SC(SC,"S",GDATE,1,L,0),"^",10)]"" S V=$P(^(0),"^",10),V=$S($D(^DIC(8,+V,0)):$P(^(0),"^",9)=13,1:0)
Q
CKP I SDREP D CKP1 Q
I 'DFN S DA(2)=SC,DA(1)=GDATE,DA=L,DIK="^SC("_DA(2)_",""S"","_DA(1)_",1," D ^DIK S POP=1 K DA,DIK Q ;SD*509 kill bad node when DFN is null
I $D(^DPT(DFN,"S",GDATE,0)),$P(^(0),"^",2)'["C",$S($D(SDI1):1,SDX["ALL":1,SDIQ=1:1,$P(^(0),"^",6)'["Y":1,1:0) S POP=0
Q
CKP1 I 'DFN S DA(2)=SC,DA(1)=GDATE,DA=L,DIK="^SC("_DA(2)_",""S"","_DA(1)_",1," D ^DIK S POP=1 K DA,DIK Q ;SD*509 kill bad node when DFN is null
I $S('$D(^DPT(DFN,"S",GDATE,0)):1,$P(^(0),"^",2)["C":1,1:0) S POP=1 Q
I SDX["ALL" S POP=0 Q
I $P(^DPT(DFN,"S",GDATE,0),"^",13)']""!($P(^(0),"^",13)=SDSTART) S POP=0,$P(^(0),"^",13)=SDSTART Q
S POP=1 Q
LIN S X=K D TM W !,$J(X,8) I $D(^SC(L,0)) W ?11,$P(^(0),"^",1) D LOC W ?42,SDLOC K SDLOC D:$D(^DPT(J,"S",K,0)) SETP W:'$D(^DPT(J,"S",K,0)) ?70,"*DELETED*" D SCCOND^SDROUT2
W:'$D(^SC(L,0)) ?11,L
D:$Y>(IOSL-5) HED^SDROUT2 Q
LOC S SDLOC=$P(^SC(L,0),"^",11) I SDLOC']"",$D(^DIC(4,+$$SITE^VASITE,"DIV")),^("DIV")="Y" S SDLOC=$S($P(^SC(L,0),"^",15)=DIV:"",$D(^DG(40.8,+$P(^SC(L,0),"^",15),0)):$P(^(0),"^",1),1:"")
Q
FUT I $O(^DPT(J,"S",SDATE_".9"))>0 D HED2 F M=SDATE_".9":0 S M=$O(^DPT(J,"S",M)) Q:M="" D:$Y>(IOSL-5) HED^SDROUT2 I $S($P(^DPT(J,"S",M,0),"^",2)']"":1,$P(^(0),"^",2)="I":1,1:0) D LIN2
I SDREP,SDX'["ALL" W !!,"DATE PRINTED : " S Y=SDSTART D DTS^SDUTL W Y,!,"DATE REPRINTED: ",PRDATE Q
W !!,"DATE PRINTED: ",PRDATE Q
LIN2 D LIN2^SDROUT1
S L=+^DPT(J,"S",M,0),X=M D TM S Y=M D DTS^SDUTL W !,Y,?11,$J(X,8),?20,$P(^SC(L,0),"^",1) D LOC W ?52,SDLOC K SDLOC
Q
HED2 W !!,?9,"**FUTURE APPOINTMENTS**"
W !!," DATE",?11,"TIME",?21,"CLINIC",?55,"LOCATION",! Q
TM I $P(X,".",2)']"" S X1=""
;IHS/ITSC/WAR 10/29/03 added a space to "M" now appears as "M "
;S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M" Q
S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M " Q
SETP S $P(^DPT(J,"S",K,0),"^",6)="Y" I $P(^(0),"^",13)']"" S $P(^(0),"^",13)=DT
Q
CLIN F G=0:0 S I=$O(^UTILITY($J,"A",I)) Q:I="" S SDTD=0 F H=0:0 S SDTD=$O(^UTILITY($J,"A",I,SDTD)) Q:SDTD="" F J=0:0 S J=$O(^UTILITY($J,"A",I,SDTD,J)) Q:J="" I ^(J) S SC=+^(J),POP=1 D FIRST I 'POP S P=0 D HED^SDROUT2,HD^SDROUT2,CNT,TIME
W:IOF]"" !,@IOF G END^SDROUT1
FIRST I ORDER=3 S POP=0 Q
F A=SDATE:0 S A=$O(^DPT(J,"S",A)) Q:(A'>0)!($P(A,".")'=SDATE) I $P(^(A,0),"^",2)'["C" S SD=+^(0) I $D(^SC(SD,0)),$S(DIV="":1,$P(^SC(SD,0),"^",15)=DIV:1,1:0) S:SD=+SC POP=0 Q
Q
TIME F K=0:0 S K=$O(^UTILITY($J,"B",J,K)) D:K="" FUT Q:K="" S L=^(K) D LIN,X1
Q
X1 I $P(^UTILITY($J,"A",I,SDTD,J),"^",2)]"" W !,?4,$P(^(J),"^",2) Q
I $D(^DPT(+J,.36)),$D(^DIC(8,+^DPT(+J,.36),0)),$P(^(0),"^",9)=13 W !,?4,"** COLLATERAL **"
Q
;
SDROUT0 ;BSN/GRR - ROUTING SLIPS BY CLINIC ;11/12/91 16:07
+1 ;;5.3;PIMS;**343,377,1015,1016**;JUN 30, 2012;Build 20
GO SET SDCNT=0
DO GO1
IF ORDER=2!(ORDER=3)
GOTO CLIN
+1 FOR G=0:0
SET I=$ORDER(^UTILITY($JOB,I))
IF I=""
QUIT
FOR J=0:0
SET J=$ORDER(^UTILITY($JOB,I,J))
IF J=""
QUIT
SET P=0
DO HED^SDROUT2
DO HD^SDROUT2
DO CNT
FOR K=0:0
SET K=$ORDER(^UTILITY($JOB,I,J,K))
IF K=""
DO FUT
IF K=""
QUIT
SET L=0
FOR LL=0:0
SET L=$ORDER(^UTILITY($JOB,I,J,K,L))
IF L=""
QUIT
DO LIN
DO X
+2 IF IOF]""
WRITE !,@IOF
GOTO END^SDROUT1
CNT SET SDCNT=SDCNT+1
QUIT
X IF $PIECE(^UTILITY($JOB,I,J,K,L),"^")]""
WRITE !,?4,$PIECE(^(L),"^")
QUIT
+1 IF $DATA(^DPT(+J,.36))
IF $DATA(^DIC(8,+^DPT(+J,.36),0))
IF $PIECE(^(0),"^",9)=13
WRITE !,?4,"** COLLATERAL **"
+2 QUIT
GO1 SET I=0
IF 'SDREP!(SDX'["ALL")!(SDSTART="0000")
QUIT
IF SDSTART?4N
SET SDZ=(SDSTART-1)/10000
SET SDZ=$PIECE(SDZ,".",2)
SET SDZ=SDZ_$EXTRACT("0000",1,4-$LENGTH(SDZ))
SET I=" "_SDZ
KILL SDZ
QUIT
+1 IF '$DATA(^UTILITY($JOB,SDSTART))
SET I=SDSTART
QUIT
+2 SET SDZ=$ASCII($EXTRACT(SDSTART,$LENGTH(SDSTART)))
SET I=$EXTRACT(SDSTART,1,$LENGTH(SDSTART)-1)_$CHAR(SDZ-1)
KILL SDZ
QUIT
GOT SET DFN=$PIECE(^SC(SC,"S",GDATE,1,L,0),"^")
SET POP=1
DO CKP
IF POP
QUIT
+1 SET NAME=$PIECE(^DPT(DFN,0),"^")
SET TDO=$PIECE(^(0),"^",9)
SET TDO=$EXTRACT(TDO,8,9)_$EXTRACT(TDO,6,7)
+2 DO ^SDROUT1
IF ORDER=1
GOTO TDO
IF ORDER=2
GOTO CLO
IF ORDER=3
GOTO PLOC
DO COL
SET ^UTILITY($JOB,NAME,DFN,GDATE,SC)=$SELECT(V:"** COLLATERAL **",1:"")
KILL V
+3 QUIT
TDO DO COL
SET ^UTILITY($JOB," "_TDO,DFN,GDATE,SC)=$SELECT(V:"** COLLATERAL **",1:"")
QUIT
CLO DO COL
SET SCN=$SELECT($DATA(^SC(SC,0)):$PIECE(^(0),"^"),1:SC)
SET ^UTILITY($JOB,"A",SCN," "_TDO,DFN)=SC_$SELECT(V:"^** COLLATERAL **",1:"")
SET ^UTILITY($JOB,"B",DFN,GDATE)=SC
KILL V
QUIT
PLOC IF VAUTC=0
IF '$DATA(VAUTC(SC))
QUIT
+1 DO COL
+2 SET SDLOC=$PIECE($GET(^SC(SC,0)),"^",11)
IF SDLOC=""
SET SDLOC="NOT DEFINED"
+3 IF SDLOC'=SDPLSRT
IF SDPLSRT'="ALL"
QUIT
+4 SET ^UTILITY($JOB,"A",SDLOC," "_TDO,DFN)=SC_$SELECT(V:"** COLLATERAL **",1:"")
+5 SET ^UTILITY($JOB,"B",DFN,GDATE)=SC
+6 KILL V
+7 QUIT
COL SET V=0
IF $PIECE(^SC(SC,"S",GDATE,1,L,0),"^",10)]""
SET V=$PIECE(^(0),"^",10)
SET V=$SELECT($DATA(^DIC(8,+V,0)):$PIECE(^(0),"^",9)=13,1:0)
+1 QUIT
CKP IF SDREP
DO CKP1
QUIT
+1 ;SD*509 kill bad node when DFN is null
IF 'DFN
SET DA(2)=SC
SET DA(1)=GDATE
SET DA=L
SET DIK="^SC("_DA(2)_",""S"","_DA(1)_",1,"
DO ^DIK
SET POP=1
KILL DA,DIK
QUIT
+2 IF $DATA(^DPT(DFN,"S",GDATE,0))
IF $PIECE(^(0),"^",2)'["C"
IF $SELECT($DATA(SDI1):1,SDX["ALL":1,SDIQ=1:1,$PIECE(^(0),"^",6)'["Y":1,1:0)
SET POP=0
+3 QUIT
CKP1 ;SD*509 kill bad node when DFN is null
IF 'DFN
SET DA(2)=SC
SET DA(1)=GDATE
SET DA=L
SET DIK="^SC("_DA(2)_",""S"","_DA(1)_",1,"
DO ^DIK
SET POP=1
KILL DA,DIK
QUIT
+1 IF $SELECT('$DATA(^DPT(DFN,"S",GDATE,0)):1,$PIECE(^(0),"^",2)["C":1,1:0)
SET POP=1
QUIT
+2 IF SDX["ALL"
SET POP=0
QUIT
+3 IF $PIECE(^DPT(DFN,"S",GDATE,0),"^",13)']""!($PIECE(^(0),"^",13)=SDSTART)
SET POP=0
SET $PIECE(^(0),"^",13)=SDSTART
QUIT
+4 SET POP=1
QUIT
LIN SET X=K
DO TM
WRITE !,$JUSTIFY(X,8)
IF $DATA(^SC(L,0))
WRITE ?11,$PIECE(^(0),"^",1)
DO LOC
WRITE ?42,SDLOC
KILL SDLOC
IF $DATA(^DPT(J,"S",K,0))
DO SETP
IF '$DATA(^DPT(J,"S",K,0))
WRITE ?70,"*DELETED*"
DO SCCOND^SDROUT2
+1 IF '$DATA(^SC(L,0))
WRITE ?11,L
+2 IF $Y>(IOSL-5)
DO HED^SDROUT2
QUIT
LOC SET SDLOC=$PIECE(^SC(L,0),"^",11)
IF SDLOC']""
IF $DATA(^DIC(4,+$$SITE^VASITE,"DIV"))
IF ^("DIV")="Y"
SET SDLOC=$SELECT($PIECE(^SC(L,0),"^",15)=DIV:"",$DATA(^DG(40.8,+$PIECE(^SC(L,0),"^",15),0)):$PIECE(^(0),"^",1),1:"")
+1 QUIT
FUT IF $ORDER(^DPT(J,"S",SDATE_".9"))>0
DO HED2
FOR M=SDATE_".9":0
SET M=$ORDER(^DPT(J,"S",M))
IF M=""
QUIT
IF $Y>(IOSL-5)
DO HED^SDROUT2
IF $SELECT($PIECE(^DPT(J,"S",M,0),"^",2)']"":1,$PIECE(^(0),"^",2)="I":1,1:0)
DO LIN2
+1 IF SDREP
IF SDX'["ALL"
WRITE !!,"DATE PRINTED : "
SET Y=SDSTART
DO DTS^SDUTL
WRITE Y,!,"DATE REPRINTED: ",PRDATE
QUIT
+2 WRITE !!,"DATE PRINTED: ",PRDATE
QUIT
LIN2 DO LIN2^SDROUT1
+1 SET L=+^DPT(J,"S",M,0)
SET X=M
DO TM
SET Y=M
DO DTS^SDUTL
WRITE !,Y,?11,$JUSTIFY(X,8),?20,$PIECE(^SC(L,0),"^",1)
DO LOC
WRITE ?52,SDLOC
KILL SDLOC
+2 QUIT
HED2 WRITE !!,?9,"**FUTURE APPOINTMENTS**"
+1 WRITE !!," DATE",?11,"TIME",?21,"CLINIC",?55,"LOCATION",!
QUIT
TM IF $PIECE(X,".",2)']""
SET X1=""
+1 ;IHS/ITSC/WAR 10/29/03 added a space to "M" now appears as "M "
+2 ;S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M" Q
+3 SET X=$EXTRACT($PIECE(X,".",2)_"0000",1,4)
SET %=X>1159
IF X>1259
SET X=X-1200
SET X=X\100_":"_$EXTRACT(X#100+100,2,3)_" "_$EXTRACT("AP",%+1)_"M "
QUIT
SETP SET $PIECE(^DPT(J,"S",K,0),"^",6)="Y"
IF $PIECE(^(0),"^",13)']""
SET $PIECE(^(0),"^",13)=DT
+1 QUIT
CLIN FOR G=0:0
SET I=$ORDER(^UTILITY($JOB,"A",I))
IF I=""
QUIT
SET SDTD=0
FOR H=0:0
SET SDTD=$ORDER(^UTILITY($JOB,"A",I,SDTD))
IF SDTD=""
QUIT
FOR J=0:0
SET J=$ORDER(^UTILITY($JOB,"A",I,SDTD,J))
IF J=""
QUIT
IF ^(J)
SET SC=+^(J)
SET POP=1
DO FIRST
IF 'POP
SET P=0
DO HED^SDROUT2
DO HD^SDROUT2
DO CNT
DO TIME
+1 IF IOF]""
WRITE !,@IOF
GOTO END^SDROUT1
FIRST IF ORDER=3
SET POP=0
QUIT
+1 FOR A=SDATE:0
SET A=$ORDER(^DPT(J,"S",A))
IF (A'>0)!($PIECE(A,".")'=SDATE)
QUIT
IF $PIECE(^(A,0),"^",2)'["C"
SET SD=+^(0)
IF $DATA(^SC(SD,0))
IF $SELECT(DIV="":1,$PIECE(^SC(SD,0),"^",15)=DIV:1,1:0)
IF SD=+SC
SET POP=0
QUIT
+2 QUIT
TIME FOR K=0:0
SET K=$ORDER(^UTILITY($JOB,"B",J,K))
IF K=""
DO FUT
IF K=""
QUIT
SET L=^(K)
DO LIN
DO X1
+1 QUIT
X1 IF $PIECE(^UTILITY($JOB,"A",I,SDTD,J),"^",2)]""
WRITE !,?4,$PIECE(^(J),"^",2)
QUIT
+1 IF $DATA(^DPT(+J,.36))
IF $DATA(^DIC(8,+^DPT(+J,.36),0))
IF $PIECE(^(0),"^",9)=13
WRITE !,?4,"** COLLATERAL **"
+2 QUIT
+3 ;
