ASDROUT0 ; IHS/ADC/PDW/ENM - ROUTING SLIPS PRINT ; [ 11/13/2002 9:31 AM ]
;;5.0;IHS SCHEDULING;**8**;MAR 25, 1999
;rewrite of VA rtn SDROUT0
; need to use non-namespaced variables for calls to other VA rtns
;IHS/ITSC/KMS, 13-Nov-2002 - Patch 8 - Cache' compliancy
;
GOT ;EP; -- SUBRTN to set up ^utility sort of patient appts
S DFN=$P(^SC(SC,"S",GDATE,1,L,0),U)
S POP=1 D CKP Q:POP
S NAME=$P(^DPT(DFN,0),U)
S TDO=$$HRN^ASDUT(DFN),TDO=$P(TDO,"-",3)_$P(TDO,"-",2)
D ^SDROUT1
I ORDER=1 D TDO Q
I ORDER=2 D CLO Q
I ORDER=3 D PCO Q
D NMO Q
;
TDO ; -- sort by terminal digit
D COL
S ^TMP("SDRS",$J," "_TDO,DFN,GDATE,SC)=$S(V:"** COLLATERAL **",1:"") Q
;
CLO ; -- sort by clinic
D COL S SCN=$S($D(^SC(SC,0)):$P(^(0),U),1:SC)
S ^TMP("SDRS",$J,"A",SCN," "_TDO,DFN)=SC_$S(V:"^** COLLATERAL **",1:"")
S ^TMP("SDRS",$J,"B",DFN,GDATE)=SC K V Q
;
PCO ; -- sort by principal clinic
NEW SCZ S SCZ=$P($G(^SC(SC,"SL")),U,5),SCZ=$S(+SCZ:SCZ,1:SC)
D COL S SCN=$S($D(^SC(SCZ,0)):$P(^(0),U),1:SCZ)
S ^TMP("SDRS",$J,"A",SCN," "_TDO,DFN)=SC_$S(V:"^** COLLATERAL **",1:"")
S ^TMP("SDRS",$J,"B",DFN,GDATE)=SC K V Q
;
NMO ; -- sort by name
D COL
S ^TMP("SDRS",$J,NAME,DFN,GDATE,SC)=$S(V:"** COLLATERAL **",1:"") K V Q
;
COL ; -- ??
S V=0 I $P(^SC(SC,"S",GDATE,1,L,0),U,10)]"" D
. S V=$P(^SC(SC,"S",GDATE,1,L,0),U,10)
. S V=$S($D(^DIC(8,+V,0)):$P(^(0),U,9)=13,1:0)
Q
;
CKP ; -- check to see if rs should be printed for patient
I SDREP D CKP1 Q
I $S('$D(^DPT(DFN,"S",GDATE,0)):1,$P(^(0),U,2)["C":1,1:0) S POP=1 Q
I $S($D(SDI1):1,SDX["ALL":1,SDIQ=1:1,$P(^DPT(DFN,"S",GDATE,0),U,6)'["Y":1,1:0) S POP=0 Q
I $P(^DPT(DFN,"S",GDATE,0),U,6)="Y",$$NEW1 S POP=0 Q
Q
;
CKP1 ; -- check if rs should be included in reprint
I $S('$D(^DPT(DFN,"S",GDATE,0)):1,$P(^(0),U,2)["C":1,1:0) S POP=1 Q
I SDX["ALL" S POP=0 Q
I $P(^DPT(DFN,"S",GDATE,0),U,13)']""!($P(^(0),U,13)=SDSTART) S POP=0,$P(^(0),U,13)=SDSTART Q
S POP=1 Q
;
;
;
GO ;EP; called to print r slips
S SDCNT=0 D GO1
I ORDER=2!(ORDER=3) D CLIN Q
;
; term digit or name order
F S I=$O(^TMP("SDRS",$J,I)) Q:I="" D
. S J=0 F S J=$O(^TMP("SDRS",$J,I,J)) Q:J="" D
.. S P=0,SDZ=0
.. D PRINT(I,J),CNT Q:$D(SDZMK) ;one rs for chart room or mk appt
.. I $D(SDZCV) D PRINT(I,J):$$RS2 D OTHER Q ;walk-in visit
.. I $$RS2 S K=0 F S K=$O(^TMP("SDRS",$J,I,J,K)) Q:K="" D
... S L=0 F S L=$O(^TMP("SDRS",$J,I,J,K,L)) Q:L="" D
.... D PRINT(I,J),CNT ;one rs for each appt
.. D OTHER
D END^SDROUT1
Q
;
GO1 ; -- SUBRTN to initialize sort
S I=0 Q:'SDREP!(SDX'["ALL")!(SDSTART="0000")
I SDSTART?4N D Q ;term digit
. S SDZ=(SDSTART-1)/10000,SDZ=$P(SDZ,".",2)
. S SDZ=SDZ_$E("0000",1,4-$L(SDZ)),I=" "_SDZ K SDZ
;
I '$D(^TMP("SDRS",$J,SDSTART)) S I=SDSTART Q
S SDZ=$A($E(SDSTART,$L(SDSTART)))
S I=$E(SDSTART,1,$L(SDSTART)-1)_$C(SDZ-1) K SDZ
Q
;
CLIN ; -- SUBRTN to print by clinic
F S I=$O(^TMP("SDRS",$J,"A",I)) Q:I="" D
. S SDTD=0 F S SDTD=$O(^TMP("SDRS",$J,"A",I,SDTD)) Q:SDTD="" D
.. S J=0 F S J=$O(^TMP("SDRS",$J,"A",I,SDTD,J)) Q:J="" D
... I ^TMP("SDRS",$J,"A",I,SDTD,J) D
.... S SC=+^TMP("SDRS",$J,"A",I,SDTD,J),P=0
.... D PRINT2(I,J) D CNT D:$$RS2 PRINT2(I,J) D OTHER
W:IOF]"" !,@IOF D END^SDROUT1
Q
;
PRINT2(I,J) ; -- SUBRTN to print rs by clinic
NEW K,L
I SDCNT>0 W @IOF
D HED^SDROUT2,HD^SDROUT2 S K=0
F S K=$O(^TMP("SDRS",$J,"B",J,K)) D:K="" FUT Q:K="" D
. S (SDZ,L)=^TMP("SDRS",$J,"B",J,K) D LIN,X1
Q
;
PRINT(I,J) ; -- SUBRTN to print a routing slip based on patient ifn J
NEW K,L
I SDCNT>0 W @IOF
D HED^SDROUT2,HD^SDROUT2
S K=0 F S K=$O(^TMP("SDRS",$J,I,J,K)) D:K="" FUT Q:K="" D
. S L=0 F S L=$O(^TMP("SDRS",$J,I,J,K,L)) Q:L="" D LIN,X
Q
;
LIN ; -- SUBRTN to print individual appointments
S X=K D TM W !,$J(X,8)
I $D(^SC(L,0)) D
. W ?11,$P(^SC(L,0),U)
. D LOC W:$$SHORT^ASDROUT2 !?11 W:'$$SHORT^ASDROUT2 ?42
. W SDLOC K SDLOC
. D:$D(^DPT(J,"S",K,0)) SETP(J,K)
. W:'$D(^DPT(J,"S",K,0)) ?70,"*DELETED*"
. D SCCOND^SDROUT2
W:'$D(^SC(L,0)) ?11,L
;
NEW X S X=0 F S X=$O(^SC(L,"S",K,1,X)) Q:'X D
. Q:$P(^SC(L,"S",K,1,X,0),U)'=J
. W:$P(^SC(L,"S",K,1,X,0),U,4)'="" !,?11,$P(^(0),U,4)
D:$Y>(IOSL-5) HED^SDROUT2
Q
;
X ; -- SUBRTN to print extra info
I $P(^TMP("SDRS",$J,I,J,K,L),U)]"" W !,?4,$P(^(L),U) Q
I $D(^DPT(+J,.36)),$D(^DIC(8,+^DPT(+J,.36),0)),$P(^(0),U,9)=13 W !,?4,"** COLLATERAL **"
Q
;
X1 ; -- SUBRTN to print extra info
I $P(^TMP("SDRS",$J,"A",I,SDTD,J),U,2)]"" W !,?4,$P(^(J),U,2) Q
I $D(^DPT(+J,.36)),$D(^DIC(8,+^DPT(+J,.36),0)),$P(^(0),U,9)=13 W !,?4,"** COLLATERAL **"
Q
;
;
LOC ; -- SUBRTN to return location
S SDLOC=$P(^SC(L,0),U,11)
I SDLOC']"",$D(^DIC(4,+^DD("SITE",1),"DIV")),^("DIV")="Y" D
. S SDLOC=$S($P(^SC(L,0),U,15)=DIV:"",$D(^DG(40.8,+$P(^SC(L,0),U,15),0)):$P(^(0),U,1),1:"")
Q
;
FUT ;EP -- SUBRTN to print future appts
I $$SHORT^ASDROUT2 D DATE Q ;short form
I $O(^DPT(J,"S",SDATE_".9"))>0 D
. I $Y>(IOSL-5) D HED^SDROUT2
. D HED2
. F M=SDATE_".9":0 S M=$O(^DPT(J,"S",M)) Q:M="" D
.. I $Y>(IOSL-5) D HED^SDROUT2,HED2
.. I $S($P(^DPT(J,"S",M,0),U,2)']"":1,$P(^(0),U,2)="I":1,1:0) D LIN2
;
DATE I SDREP,SDX'["ALL" D Q
. W !!,"DATE PRINTED : " S Y=SDSTART D DTS^SDUTL
. W Y,!,"DATE REPRINTED: ",PRDATE
W !!,"DATE PRINTED: ",PRDATE
W !,"Requested by: ",$P($G(^VA(200,+$G(DUZ),0)),U)
Q
;
LIN2 ; -- SUBRTN to print future appts line
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),U,1) D LOC W ?52,SDLOC K SDLOC
I $P($G(^SC(L,9999999)),U,7)]"" W !?13,$P(^(9999999),U,7)
Q
;
HED2 ;EP -- SUBRTN to print future appt heading
W !!,?9,"**FUTURE APPOINTMENTS**"
W !!," DATE",?11,"TIME",?21,"CLINIC",?55,"LOCATION",!
Q
;
TM ; -- SUBRTN for printable time
I $P(X,".",2)']"" S X1=""
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(J,K) ; -- called to set date printed
NEW DIE,DA,DR,END
Q:J<1 Q:K<1
S DIE="^DPT("_J_",""S"",",DA=K\1,DA(1)=J,END=DA+.2400
F S DA=$O(^DPT(J,"S",DA)) Q:DA=""!(DA>END) D
. Q:$P(^DPT(J,"S",DA,0),U,2)["C"
. S DR="8///Y" S:$P(^DPT(J,"S",DA,0),U,13)="" DR=DR_";8.5///"_DT
. D ^DIE
Q
;
OTHER ; -- calls other forms
; searhc/maw these all get set up in the clinic setup option
Q:$P($G(^DG(40.8,$$DIV,"IHS")),U,4)'=1 ;others not print with rs
D EF ; encounter form
D HS ; health summary
D MP ; med profile
D AIU ; address/insurance update
Q
;
EF ; -- encounter form
Q:$G(SDZEF) Q:'$$ONE(J,5) W @IOF D EF^ASDFORM(SC,J,SDATE) Q
;
HS ; -- health summary
;IHS/ITSC/KMS, 13-Nov-2002 Added extra space " " after QUIT for Cache' compliance - KMS
;I $G(SDZHS) Q ;searhc/maw removed form feed
I $G(SDZHS) Q ;searhc/maw removed form feed
;I $G(SDZHS) W @IOF Q
;IHS/ITSC/KMS, 13-Nov-2002 Added extra space " " after QUIT for Cache' compliance - KMS
;I '$$ONE(J,1) Q ;searhc/maw removed form feed
I '$$ONE(J,1) Q ;searhc/maw removed form feed
;I '$$ONE(J,1) W @IOF Q
D HS^ASDFORM(J,$P($$ONE(J,1),U,2)) Q
;
MP ; -- med profile
Q:$G(SDZMP) Q:'$$ONE(J,3) D MP^ASDFORM(J) Q
;
AIU ; -- insurance update
Q:$G(SDZAI) Q:'$$ONE(J,4) D AIU^ASDFORM(J) Q
;
NEW1() ; -- returns 1 if patient has new appt on same day
NEW X,Y
S Y=0,X=GDATE\1
F S X=$O(^DPT(DFN,"S",X)) Q:X="" Q:X>(GDATE+.2400) Q:Y=1 D
. Q:$P(^DPT(DFN,"S",X,0),U,2)["C"
. I $P(^DPT(DFN,"S",X,0),U,13)=""!($P(^(0),U,13)=SDSTART) S Y=1
Q Y
;
ONE(DFN,FORM) ; -- returns 1 if at least one clinic for pat wants form
NEW X,Y,Z
S Y=0,X=SDATE\1
F S X=$O(^DPT(DFN,"S",X)) Q:X="" Q:X>(SDATE+.2400) Q:Y=1 D
. S Z=$P($G(^DPT(DFN,"S",X,0)),U) Q:Z="" Q:$P(^(0),U,2)["C"
. I $P($G(^SC(Z,9999999)),U,FORM)="Y" S Y=1
. I FORM=1,$$HSTYP^ASDUT(Z,DFN)="" S Y=0
. I FORM=1,Y=1 S Y=1_U_$$HSTYP^ASDUT(Z,DFN)
Q Y
;
CNT ; -- increment # of routing slips printed
S SDCNT=SDCNT+1 Q
;
RS2() ; -- returns 1 if want >1 rs
Q $P($G(^DG(40.8,$$DIV,"IHS")),U,3)
;
DIV() ; -- returns division ien
Q $O(^DG(40.8,"C",DUZ(2),0))
ASDROUT0 ; IHS/ADC/PDW/ENM - ROUTING SLIPS PRINT ; [ 11/13/2002 9:31 AM ]
+1 ;;5.0;IHS SCHEDULING;**8**;MAR 25, 1999
+2 ;rewrite of VA rtn SDROUT0
+3 ; need to use non-namespaced variables for calls to other VA rtns
+4 ;IHS/ITSC/KMS, 13-Nov-2002 - Patch 8 - Cache' compliancy
+5 ;
GOT ;EP; -- SUBRTN to set up ^utility sort of patient appts
+1 SET DFN=$PIECE(^SC(SC,"S",GDATE,1,L,0),U)
+2 SET POP=1
DO CKP
IF POP
QUIT
+3 SET NAME=$PIECE(^DPT(DFN,0),U)
+4 SET TDO=$$HRN^ASDUT(DFN)
SET TDO=$PIECE(TDO,"-",3)_$PIECE(TDO,"-",2)
+5 DO ^SDROUT1
+6 IF ORDER=1
DO TDO
QUIT
+7 IF ORDER=2
DO CLO
QUIT
+8 IF ORDER=3
DO PCO
QUIT
+9 DO NMO
QUIT
+10 ;
TDO ; -- sort by terminal digit
+1 DO COL
+2 SET ^TMP("SDRS",$JOB," "_TDO,DFN,GDATE,SC)=$SELECT(V:"** COLLATERAL **",1:"")
QUIT
+3 ;
CLO ; -- sort by clinic
+1 DO COL
SET SCN=$SELECT($DATA(^SC(SC,0)):$PIECE(^(0),U),1:SC)
+2 SET ^TMP("SDRS",$JOB,"A",SCN," "_TDO,DFN)=SC_$SELECT(V:"^** COLLATERAL **",1:"")
+3 SET ^TMP("SDRS",$JOB,"B",DFN,GDATE)=SC
KILL V
QUIT
+4 ;
PCO ; -- sort by principal clinic
+1 NEW SCZ
SET SCZ=$PIECE($GET(^SC(SC,"SL")),U,5)
SET SCZ=$SELECT(+SCZ:SCZ,1:SC)
+2 DO COL
SET SCN=$SELECT($DATA(^SC(SCZ,0)):$PIECE(^(0),U),1:SCZ)
+3 SET ^TMP("SDRS",$JOB,"A",SCN," "_TDO,DFN)=SC_$SELECT(V:"^** COLLATERAL **",1:"")
+4 SET ^TMP("SDRS",$JOB,"B",DFN,GDATE)=SC
KILL V
QUIT
+5 ;
NMO ; -- sort by name
+1 DO COL
+2 SET ^TMP("SDRS",$JOB,NAME,DFN,GDATE,SC)=$SELECT(V:"** COLLATERAL **",1:"")
KILL V
QUIT
+3 ;
COL ; -- ??
+1 SET V=0
IF $PIECE(^SC(SC,"S",GDATE,1,L,0),U,10)]""
Begin DoDot:1
+2 SET V=$PIECE(^SC(SC,"S",GDATE,1,L,0),U,10)
+3 SET V=$SELECT($DATA(^DIC(8,+V,0)):$PIECE(^(0),U,9)=13,1:0)
End DoDot:1
+4 QUIT
+5 ;
CKP ; -- check to see if rs should be printed for patient
+1 IF SDREP
DO CKP1
QUIT
+2 IF $SELECT('$DATA(^DPT(DFN,"S",GDATE,0)):1,$PIECE(^(0),U,2)["C":1,1:0)
SET POP=1
QUIT
+3 IF $SELECT($DATA(SDI1):1,SDX["ALL":1,SDIQ=1:1,$PIECE(^DPT(DFN,"S",GDATE,0),U,6)'["Y":1,1:0)
SET POP=0
QUIT
+4 IF $PIECE(^DPT(DFN,"S",GDATE,0),U,6)="Y"
IF $$NEW1
SET POP=0
QUIT
+5 QUIT
+6 ;
CKP1 ; -- check if rs should be included in reprint
+1 IF $SELECT('$DATA(^DPT(DFN,"S",GDATE,0)):1,$PIECE(^(0),U,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),U,13)']""!($PIECE(^(0),U,13)=SDSTART)
SET POP=0
SET $PIECE(^(0),U,13)=SDSTART
QUIT
+4 SET POP=1
QUIT
+5 ;
+6 ;
+7 ;
GO ;EP; called to print r slips
+1 SET SDCNT=0
DO GO1
+2 IF ORDER=2!(ORDER=3)
DO CLIN
QUIT
+3 ;
+4 ; term digit or name order
+5 FOR
SET I=$ORDER(^TMP("SDRS",$JOB,I))
IF I=""
QUIT
Begin DoDot:1
+6 SET J=0
FOR
SET J=$ORDER(^TMP("SDRS",$JOB,I,J))
IF J=""
QUIT
Begin DoDot:2
+7 SET P=0
SET SDZ=0
+8 ;one rs for chart room or mk appt
DO PRINT(I,J)
DO CNT
IF $DATA(SDZMK)
QUIT
+9 ;walk-in visit
IF $DATA(SDZCV)
IF $$RS2
DO PRINT(I,J)
DO OTHER
QUIT
+10 IF $$RS2
SET K=0
FOR
SET K=$ORDER(^TMP("SDRS",$JOB,I,J,K))
IF K=""
QUIT
Begin DoDot:3
+11 SET L=0
FOR
SET L=$ORDER(^TMP("SDRS",$JOB,I,J,K,L))
IF L=""
QUIT
Begin DoDot:4
+12 ;one rs for each appt
DO PRINT(I,J)
DO CNT
End DoDot:4
End DoDot:3
+13 DO OTHER
End DoDot:2
End DoDot:1
+14 DO END^SDROUT1
+15 QUIT
+16 ;
GO1 ; -- SUBRTN to initialize sort
+1 SET I=0
IF 'SDREP!(SDX'["ALL")!(SDSTART="0000")
QUIT
+2 ;term digit
IF SDSTART?4N
Begin DoDot:1
+3 SET SDZ=(SDSTART-1)/10000
SET SDZ=$PIECE(SDZ,".",2)
+4 SET SDZ=SDZ_$EXTRACT("0000",1,4-$LENGTH(SDZ))
SET I=" "_SDZ
KILL SDZ
End DoDot:1
QUIT
+5 ;
+6 IF '$DATA(^TMP("SDRS",$JOB,SDSTART))
SET I=SDSTART
QUIT
+7 SET SDZ=$ASCII($EXTRACT(SDSTART,$LENGTH(SDSTART)))
+8 SET I=$EXTRACT(SDSTART,1,$LENGTH(SDSTART)-1)_$CHAR(SDZ-1)
KILL SDZ
+9 QUIT
+10 ;
CLIN ; -- SUBRTN to print by clinic
+1 FOR
SET I=$ORDER(^TMP("SDRS",$JOB,"A",I))
IF I=""
QUIT
Begin DoDot:1
+2 SET SDTD=0
FOR
SET SDTD=$ORDER(^TMP("SDRS",$JOB,"A",I,SDTD))
IF SDTD=""
QUIT
Begin DoDot:2
+3 SET J=0
FOR
SET J=$ORDER(^TMP("SDRS",$JOB,"A",I,SDTD,J))
IF J=""
QUIT
Begin DoDot:3
+4 IF ^TMP("SDRS",$JOB,"A",I,SDTD,J)
Begin DoDot:4
+5 SET SC=+^TMP("SDRS",$JOB,"A",I,SDTD,J)
SET P=0
+6 DO PRINT2(I,J)
DO CNT
IF $$RS2
DO PRINT2(I,J)
DO OTHER
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+7 IF IOF]""
WRITE !,@IOF
DO END^SDROUT1
+8 QUIT
+9 ;
PRINT2(I,J) ; -- SUBRTN to print rs by clinic
+1 NEW K,L
+2 IF SDCNT>0
WRITE @IOF
+3 DO HED^SDROUT2
DO HD^SDROUT2
SET K=0
+4 FOR
SET K=$ORDER(^TMP("SDRS",$JOB,"B",J,K))
IF K=""
DO FUT
IF K=""
QUIT
Begin DoDot:1
+5 SET (SDZ,L)=^TMP("SDRS",$JOB,"B",J,K)
DO LIN
DO X1
End DoDot:1
+6 QUIT
+7 ;
PRINT(I,J) ; -- SUBRTN to print a routing slip based on patient ifn J
+1 NEW K,L
+2 IF SDCNT>0
WRITE @IOF
+3 DO HED^SDROUT2
DO HD^SDROUT2
+4 SET K=0
FOR
SET K=$ORDER(^TMP("SDRS",$JOB,I,J,K))
IF K=""
DO FUT
IF K=""
QUIT
Begin DoDot:1
+5 SET L=0
FOR
SET L=$ORDER(^TMP("SDRS",$JOB,I,J,K,L))
IF L=""
QUIT
DO LIN
DO X
End DoDot:1
+6 QUIT
+7 ;
LIN ; -- SUBRTN to print individual appointments
+1 SET X=K
DO TM
WRITE !,$JUSTIFY(X,8)
+2 IF $DATA(^SC(L,0))
Begin DoDot:1
+3 WRITE ?11,$PIECE(^SC(L,0),U)
+4 DO LOC
IF $$SHORT^ASDROUT2
WRITE !?11
IF '$$SHORT^ASDROUT2
WRITE ?42
+5 WRITE SDLOC
KILL SDLOC
+6 IF $DATA(^DPT(J,"S",K,0))
DO SETP(J,K)
+7 IF '$DATA(^DPT(J,"S",K,0))
WRITE ?70,"*DELETED*"
+8 DO SCCOND^SDROUT2
End DoDot:1
+9 IF '$DATA(^SC(L,0))
WRITE ?11,L
+10 ;
+11 NEW X
SET X=0
FOR
SET X=$ORDER(^SC(L,"S",K,1,X))
IF 'X
QUIT
Begin DoDot:1
+12 IF $PIECE(^SC(L,"S",K,1,X,0),U)'=J
QUIT
+13 IF $PIECE(^SC(L,"S",K,1,X,0),U,4)'=""
WRITE !,?11,$PIECE(^(0),U,4)
End DoDot:1
+14 IF $Y>(IOSL-5)
DO HED^SDROUT2
+15 QUIT
+16 ;
X ; -- SUBRTN to print extra info
+1 IF $PIECE(^TMP("SDRS",$JOB,I,J,K,L),U)]""
WRITE !,?4,$PIECE(^(L),U)
QUIT
+2 IF $DATA(^DPT(+J,.36))
IF $DATA(^DIC(8,+^DPT(+J,.36),0))
IF $PIECE(^(0),U,9)=13
WRITE !,?4,"** COLLATERAL **"
+3 QUIT
+4 ;
X1 ; -- SUBRTN to print extra info
+1 IF $PIECE(^TMP("SDRS",$JOB,"A",I,SDTD,J),U,2)]""
WRITE !,?4,$PIECE(^(J),U,2)
QUIT
+2 IF $DATA(^DPT(+J,.36))
IF $DATA(^DIC(8,+^DPT(+J,.36),0))
IF $PIECE(^(0),U,9)=13
WRITE !,?4,"** COLLATERAL **"
+3 QUIT
+4 ;
+5 ;
LOC ; -- SUBRTN to return location
+1 SET SDLOC=$PIECE(^SC(L,0),U,11)
+2 IF SDLOC']""
IF $DATA(^DIC(4,+^DD("SITE",1),"DIV"))
IF ^("DIV")="Y"
Begin DoDot:1
+3 SET SDLOC=$SELECT($PIECE(^SC(L,0),U,15)=DIV:"",$DATA(^DG(40.8,+$PIECE(^SC(L,0),U,15),0)):$PIECE(^(0),U,1),1:"")
End DoDot:1
+4 QUIT
+5 ;
FUT ;EP -- SUBRTN to print future appts
+1 ;short form
IF $$SHORT^ASDROUT2
DO DATE
QUIT
+2 IF $ORDER(^DPT(J,"S",SDATE_".9"))>0
Begin DoDot:1
+3 IF $Y>(IOSL-5)
DO HED^SDROUT2
+4 DO HED2
+5 FOR M=SDATE_".9":0
SET M=$ORDER(^DPT(J,"S",M))
IF M=""
QUIT
Begin DoDot:2
+6 IF $Y>(IOSL-5)
DO HED^SDROUT2
DO HED2
+7 IF $SELECT($PIECE(^DPT(J,"S",M,0),U,2)']"":1,$PIECE(^(0),U,2)="I":1,1:0)
DO LIN2
End DoDot:2
End DoDot:1
+8 ;
DATE IF SDREP
IF SDX'["ALL"
Begin DoDot:1
+1 WRITE !!,"DATE PRINTED : "
SET Y=SDSTART
DO DTS^SDUTL
+2 WRITE Y,!,"DATE REPRINTED: ",PRDATE
End DoDot:1
QUIT
+3 WRITE !!,"DATE PRINTED: ",PRDATE
+4 WRITE !,"Requested by: ",$PIECE($GET(^VA(200,+$GET(DUZ),0)),U)
+5 QUIT
+6 ;
LIN2 ; -- SUBRTN to print future appts line
+1 DO LIN2^SDROUT1
+2 SET L=+^DPT(J,"S",M,0)
SET X=M
DO TM
SET Y=M
DO DTS^SDUTL
+3 WRITE !,Y,?11,$JUSTIFY(X,8),?20,$PIECE(^SC(L,0),U,1)
DO LOC
WRITE ?52,SDLOC
KILL SDLOC
+4 IF $PIECE($GET(^SC(L,9999999)),U,7)]""
WRITE !?13,$PIECE(^(9999999),U,7)
+5 QUIT
+6 ;
HED2 ;EP -- SUBRTN to print future appt heading
+1 WRITE !!,?9,"**FUTURE APPOINTMENTS**"
+2 WRITE !!," DATE",?11,"TIME",?21,"CLINIC",?55,"LOCATION",!
+3 QUIT
+4 ;
TM ; -- SUBRTN for printable time
+1 IF $PIECE(X,".",2)']""
SET X1=""
+2 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"
+3 QUIT
+4 ;
SETP(J,K) ; -- called to set date printed
+1 NEW DIE,DA,DR,END
+2 IF J<1
QUIT
IF K<1
QUIT
+3 SET DIE="^DPT("_J_",""S"","
SET DA=K\1
SET DA(1)=J
SET END=DA+.2400
+4 FOR
SET DA=$ORDER(^DPT(J,"S",DA))
IF DA=""!(DA>END)
QUIT
Begin DoDot:1
+5 IF $PIECE(^DPT(J,"S",DA,0),U,2)["C"
QUIT
+6 SET DR="8///Y"
IF $PIECE(^DPT(J,"S",DA,0),U,13)=""
SET DR=DR_";8.5///"_DT
+7 DO ^DIE
End DoDot:1
+8 QUIT
+9 ;
OTHER ; -- calls other forms
+1 ; searhc/maw these all get set up in the clinic setup option
+2 ;others not print with rs
IF $PIECE($GET(^DG(40.8,$$DIV,"IHS")),U,4)'=1
QUIT
+3 ; encounter form
DO EF
+4 ; health summary
DO HS
+5 ; med profile
DO MP
+6 ; address/insurance update
DO AIU
+7 QUIT
+8 ;
EF ; -- encounter form
+1 IF $GET(SDZEF)
QUIT
IF '$$ONE(J,5)
QUIT
WRITE @IOF
DO EF^ASDFORM(SC,J,SDATE)
QUIT
+2 ;
HS ; -- health summary
+1 ;IHS/ITSC/KMS, 13-Nov-2002 Added extra space " " after QUIT for Cache' compliance - KMS
+2 ;I $G(SDZHS) Q ;searhc/maw removed form feed
+3 ;searhc/maw removed form feed
IF $GET(SDZHS)
QUIT
+4 ;I $G(SDZHS) W @IOF Q
+5 ;IHS/ITSC/KMS, 13-Nov-2002 Added extra space " " after QUIT for Cache' compliance - KMS
+6 ;I '$$ONE(J,1) Q ;searhc/maw removed form feed
+7 ;searhc/maw removed form feed
IF '$$ONE(J,1)
QUIT
+8 ;I '$$ONE(J,1) W @IOF Q
+9 DO HS^ASDFORM(J,$PIECE($$ONE(J,1),U,2))
QUIT
+10 ;
MP ; -- med profile
+1 IF $GET(SDZMP)
QUIT
IF '$$ONE(J,3)
QUIT
DO MP^ASDFORM(J)
QUIT
+2 ;
AIU ; -- insurance update
+1 IF $GET(SDZAI)
QUIT
IF '$$ONE(J,4)
QUIT
DO AIU^ASDFORM(J)
QUIT
+2 ;
NEW1() ; -- returns 1 if patient has new appt on same day
+1 NEW X,Y
+2 SET Y=0
SET X=GDATE\1
+3 FOR
SET X=$ORDER(^DPT(DFN,"S",X))
IF X=""
QUIT
IF X>(GDATE+.2400)
QUIT
IF Y=1
QUIT
Begin DoDot:1
+4 IF $PIECE(^DPT(DFN,"S",X,0),U,2)["C"
QUIT
+5 IF $PIECE(^DPT(DFN,"S",X,0),U,13)=""!($PIECE(^(0),U,13)=SDSTART)
SET Y=1
End DoDot:1
+6 QUIT Y
+7 ;
ONE(DFN,FORM) ; -- returns 1 if at least one clinic for pat wants form
+1 NEW X,Y,Z
+2 SET Y=0
SET X=SDATE\1
+3 FOR
SET X=$ORDER(^DPT(DFN,"S",X))
IF X=""
QUIT
IF X>(SDATE+.2400)
QUIT
IF Y=1
QUIT
Begin DoDot:1
+4 SET Z=$PIECE($GET(^DPT(DFN,"S",X,0)),U)
IF Z=""
QUIT
IF $PIECE(^(0),U,2)["C"
QUIT
+5 IF $PIECE($GET(^SC(Z,9999999)),U,FORM)="Y"
SET Y=1
+6 IF FORM=1
IF $$HSTYP^ASDUT(Z,DFN)=""
SET Y=0
+7 IF FORM=1
IF Y=1
SET Y=1_U_$$HSTYP^ASDUT(Z,DFN)
End DoDot:1
+8 QUIT Y
+9 ;
CNT ; -- increment # of routing slips printed
+1 SET SDCNT=SDCNT+1
QUIT
+2 ;
RS2() ; -- returns 1 if want >1 rs
+1 QUIT $PIECE($GET(^DG(40.8,$$DIV,"IHS")),U,3)
+2 ;
DIV() ; -- returns division ien
+1 QUIT $ORDER(^DG(40.8,"C",DUZ(2),0))
