- 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 ;
