SDROUT ;BSN/GRR - ROUTING SLIPS ; 26 APR 84 11:26 am
;;5.3;Scheduling;**3,39,377,1013,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 11/15/2000 added IHS call for sorts & reprint questions
; added kill of ^TMP (used instead of ^UTILITY)
; changed $N to $O
; checked for "include on file room list=no"
; 11/17/2000 added IHS call for single patient rs
; 11/22/2000 added call to find chart requests to print
; 12/06/2000 made all vs. add-on question clearer
; 11/02/2001 added code to print range for ALL
;ihs/cmi/maw 04/11/2011 PATCH 1013 RQMT151
;
N VAUTC,SDPLSRT,SDMATCH
S SDSTOP="" ;IHS/ANMC/LJF 11/02/2001
S (SDIQ,SDX,DIV,SDREP,SDSTART)="" D DIV^SDUTL I $T D ROUT^SDDIV G:Y<0 END
R1 S %=2 W !,"DO YOU WANT ROUTING SHEET FOR A SINGLE PATIENT" D YN^DICN I '% D QQ G R1
;G:%<0 END S SDSP=$S(%=2:"N",1:"Y") G:SDSP["Y" SIN1^SDROUT1
G:%<0 END S SDSP=$S(%=2:"N",1:"Y") G:SDSP["Y" ONE^BSDROUT ;IHS/ANMC/LJF 11/17/2000
R2 ;R !,"WANT (A)LL ROUTING SHEETS OR (O)NLY ADD-ONS: ONLY ADD-ONS// ",X:DTIME G:X["^"!('$T) END I X="" S X="O" W X ;IHS/ANMC/LJF 12/06/2000
;ihs/cmi/maw 04/11/2011 Patch 1013 RQMT151 for routing slip default
N BSDRSDF,BSDPROM
S BSDRSDF=$S($G(DIV):$$GET1^DIQ(9009020.2,DIV,.27,"I"),1:"O")
;R !,"Select All Routing Slips (A) or Only Add-ons (O): O// ",X:DTIME G:X["^"!('$T) END I X="" S X="O" W X ;IHS/ANMC/LJF 12/06/2000
S DIR(0)="S^A:All Routing Slips;O:Only Add-Ons",DIR("A")="Select All Routing Slips (A) or Only Add-ons (O): "
S DIR("B")=BSDRSDF
D ^DIR
G END:$D(DIRUT)
S Z="^ALL ROUTING SHEETS^ONLY ADD-ONS" D IN^DGHELP I %=-1 W !?12,"CHOOSE FROM:",!?12,"O - To only see add-ons",!?9,"or A - To see all routing sheets" G R2
S SDX=$S(X="O":"ADD-ONS",1:"ALL")
;
D ASK^BSDROUT Q ;IHS/ANMC/LJF 11/15/2000
;
R22 S ORDER=0,DIR(0)="S^T:TERMINAL DIGIT;N:NAME;C:CLINIC;P:PHYSICAL LOCATION",DIR("B")="T",DIR("A")="PRINT IN",DIR("?")="^D HELP^SDROUT" D ^DIR
G:Y<0!$D(DTOUT)!$D(DIROUT)!$D(DIRUT) R2
S X=Y K DIR,DTOUT,DIROUT,DIRUT
R4 S ORDER=$S(X="T":1,X="N":"",X="P":3,1:2)
;
RPL I ORDER=3 D
.S DIR("?")="Enter Physical Location to sort by. Must be an exact match"
.S DIR("??")="Enter Physical Location to sort by. Must be an exact matchas this is a Free Text field."
.S DIR(0)="F^1:25",DIR("A")="ENTER PHYSICAL LOCATION TO SORT BY"
.S DIR("B")="ALL" D ^DIR
I ORDER=3,Y<0!$D(DTOUT)!$D(DIROUT)!$D(DIRUT) Q
I ORDER=3 S SDPLSRT=X
I ORDER=3,$$PLVAL'=1 W !,"Not an exact match!" G RPL
I ORDER=3 K DIR,DTOUT,DIROUT,DIRUT
;
D:'$D(DT) DT^SDUTL S %DT="AEXF",%DT("A")="PRINT ROUTING SLIPS FOR WHAT DATE: " D ^%DT K %DT("A") G:Y<1 END S SDATE=Y
A5 S %=2 W !,"IS THIS A REPRINT OF A PREVIOUS RUN" D YN^DICN I '% D QQ G A5
Q:%<0 I '(%-1) S POP=0 D REP^SDROUT1 Q:POP
I ORDER=2,SDREP="" G END:'$$CLINIC(DIV,.VAUTC)
I ORDER=3,SDREP="" G END:'$$CLINIC(DIV,.VAUTC)
S VAR="DIV^VAUTC^VAUTC(^SDX^ORDER^SDATE^SDIQ^SDREP^SDSTART^SDLOC^SDPLSRT"
S DGPGM="START^SDROUT"
D ZIS^DGUTQ G:POP END^SDROUT1
G START
START ;EP; IHS/ANMC/LJF 11/15/2000 called by BSDROUT to return to VA code
K ^TMP("SDRS",$J) ;IHS/ANMC/LJF 11/15/2000 IHS code uses ^TMP
K ^UTILITY($J) U IO
S Y=SDATE D DTS^SDUTL S APDATE=Y,Y=DT D DTS^SDUTL S PRDATE=Y
;
;
;IHS/ANMC/LJF 11/15/2000 11/02/2001 changed $N to $O, added IHS call
;F SC=0:0 S SC=$N(^SC(SC)) Q:SC'>0 D CHECK I $T S GDATE=SDATE F K=0:0 S GDATE=$N(^SC(SC,"S",GDATE)) ;split line - too ling with semi-colon added
;Q:GDATE<0!(GDATE>(SDATE+1)) I $D(^SC(SC,"S",GDATE,1)) F L=0:0 S L=$N(^SC(SC,"S",GDATE,1,L)) Q:L<0 I $D(^(L,0)),$P(^(0),U,9)'="C" D GOT^SDROUT0
S SC=0 F S SC=$O(^SC(SC)) Q:'SC D CHECK I $T D
. S GDATE=SDATE
. F S GDATE=$O(^SC(SC,"S",GDATE)) Q:('GDATE)!(GDATE>(SDATE+1)) D
.. I $D(^SC(SC,"S",GDATE,1)) F L=0:0 S L=$O(^SC(SC,"S",GDATE,1,L)) Q:'L I $D(^(L,0)),$P(^(0),U,9)'="C" D FIND^BSDROUT0(SC,GDATE,L,ORDER,"")
D CRLOOP^BSDROUT2
D PRINT^BSDROUT1(ORDER,SDATE) Q
;IHS/ANMC/LJF 11/15/2000 11/02/2001
;
G GO^SDROUT0
;IHS/ANMC/LJF 11/15/2000 file room list check added
CHECK ;I $P(^SC(SC,0),"^",3)="C",$S(DIV="":1,$P(^SC(SC,0),"^",15)=DIV:1,1:0),$S('$D(^SC(SC,"I")):1,+^("I")=0:1,+^("I")>SDATE:1,+$P(^("I"),"^",2)'>SDATE&(+$P(^("I"),"^",2)):1,1:0)
I $P(^SC(SC,0),U,21)'=0,$P(^SC(SC,0),"^",3)="C",$S(DIV="":1,$P(^SC(SC,0),"^",15)=DIV:1,1:0),$S('$D(^SC(SC,"I")):1,+^("I")=0:1,+^("I")>SDATE:1,+$P(^("I"),"^",2)'>SDATE&(+$P(^("I"),"^",2)):1,1:0)
I $T,$S(ORDER'=2:1,SDREP:1,VAUTC=1:1,1:$D(VAUTC(SC)))
Q
QQ W !,"RESPOND YES OR NO" Q
END K VAUTC,ALL,DIV,ORD,ORDER,RMSEL,SDIQ,SDREP,SDSP,SDSTART,SDX,X,Y,C,V,I,SDEF,%I Q
;
CLINIC(SDIV,VAUTC) ;
N DIV,SDX,ORDER,SDATE,SDIQ,SDREP,SDSTART,VAUTD
I 'SDIV S VAUTD=1
I SDIV S VAUTD=0,VAUTD(SDIV)=$P($G(^DG(40.8,SDIV,0)),U)
Q $$CLINIC1()
;
CLINIC1() ; -- get clinic data
; input: VAUTD := divisions selected
; output: VAUTC := clinic selected (VAUTC=1 for all)
; return: was selection made [ 1|yes 0|no]
;
W !!,$$LINE^SDAMO("Clinic Selection")
;
; -- select clinics
; -- call generic clinic screen, correct division
;
S DIC("S")="I $$CLINIC2^SDROUT(Y),$S(VAUTD:1,$D(VAUTD(+$P(^SC(Y,0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)"
S DIC="^SC(",VAUTSTR="clinic",VAUTVB="VAUTC",VAUTNI=2
D FIRST^VAUTOMA
;
I Y<0 K VAUTC
CLINICQ Q $D(VAUTC)>0
;
CLINIC2(SDCL) ; -- generic screen for hos. loc. entries
; input: SDCL := ifn of HOSPITAL LOCATION file
; returned := [ 0 | do not use entry ; 1 | use entry ]
;
; -- must be a clinic
N X S X=$G(^SC(SDCL,0))
Q $P(X,"^",3)="C"
;
PLVAL() ; Physical Location Validation.
N SDCLIN,SDPLOC
S SDMATCH=0
I SDPLSRT="ALL" S SDMATCH=1 Q SDMATCH
S SDCLIN="" F S SDCLIN=$O(^SC(SDCLIN)) Q:SDCLIN=""!(SDMATCH=1) D
.S SDPLOC=$P($G(^SC(SDCLIN,0)),"^",11)
.I SDPLOC=SDPLSRT S SDMATCH=1
Q SDMATCH
HELP W !?12,"CHOOSE FROM:",!?12,"T - To see routing slips sorted in terminal digit order",!?12,"N - To see routing slips sorted in alphabetical order by name",!?12,"C - To see routing slips printed by clinic " D
.W !,?12,"or P - To see routing slip printed by physical location"
SDROUT ;BSN/GRR - ROUTING SLIPS ; 26 APR 84 11:26 am
+1 ;;5.3;Scheduling;**3,39,377,1013,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 11/15/2000 added IHS call for sorts & reprint questions
+3 ; added kill of ^TMP (used instead of ^UTILITY)
+4 ; changed $N to $O
+5 ; checked for "include on file room list=no"
+6 ; 11/17/2000 added IHS call for single patient rs
+7 ; 11/22/2000 added call to find chart requests to print
+8 ; 12/06/2000 made all vs. add-on question clearer
+9 ; 11/02/2001 added code to print range for ALL
+10 ;ihs/cmi/maw 04/11/2011 PATCH 1013 RQMT151
+11 ;
+12 NEW VAUTC,SDPLSRT,SDMATCH
+13 ;IHS/ANMC/LJF 11/02/2001
SET SDSTOP=""
+14 SET (SDIQ,SDX,DIV,SDREP,SDSTART)=""
DO DIV^SDUTL
IF $TEST
DO ROUT^SDDIV
IF Y<0
GOTO END
R1 SET %=2
WRITE !,"DO YOU WANT ROUTING SHEET FOR A SINGLE PATIENT"
DO YN^DICN
IF '%
DO QQ
GOTO R1
+1 ;G:%<0 END S SDSP=$S(%=2:"N",1:"Y") G:SDSP["Y" SIN1^SDROUT1
+2 ;IHS/ANMC/LJF 11/17/2000
IF %<0
GOTO END
SET SDSP=$SELECT(%=2:"N",1:"Y")
IF SDSP["Y"
GOTO ONE^BSDROUT
R2 ;R !,"WANT (A)LL ROUTING SHEETS OR (O)NLY ADD-ONS: ONLY ADD-ONS// ",X:DTIME G:X["^"!('$T) END I X="" S X="O" W X ;IHS/ANMC/LJF 12/06/2000
+1 ;ihs/cmi/maw 04/11/2011 Patch 1013 RQMT151 for routing slip default
+2 NEW BSDRSDF,BSDPROM
+3 SET BSDRSDF=$SELECT($GET(DIV):$$GET1^DIQ(9009020.2,DIV,.27,"I"),1:"O")
+4 ;R !,"Select All Routing Slips (A) or Only Add-ons (O): O// ",X:DTIME G:X["^"!('$T) END I X="" S X="O" W X ;IHS/ANMC/LJF 12/06/2000
+5 SET DIR(0)="S^A:All Routing Slips;O:Only Add-Ons"
SET DIR("A")="Select All Routing Slips (A) or Only Add-ons (O): "
+6 SET DIR("B")=BSDRSDF
+7 DO ^DIR
+8 IF $DATA(DIRUT)
GOTO END
+9 SET Z="^ALL ROUTING SHEETS^ONLY ADD-ONS"
DO IN^DGHELP
IF %=-1
WRITE !?12,"CHOOSE FROM:",!?12,"O - To only see add-ons",!?9,"or A - To see all routing sheets"
GOTO R2
+10 SET SDX=$SELECT(X="O":"ADD-ONS",1:"ALL")
+11 ;
+12 ;IHS/ANMC/LJF 11/15/2000
DO ASK^BSDROUT
QUIT
+13 ;
R22 SET ORDER=0
SET DIR(0)="S^T:TERMINAL DIGIT;N:NAME;C:CLINIC;P:PHYSICAL LOCATION"
SET DIR("B")="T"
SET DIR("A")="PRINT IN"
SET DIR("?")="^D HELP^SDROUT"
DO ^DIR
+1 IF Y<0!$DATA(DTOUT)!$DATA(DIROUT)!$DATA(DIRUT)
GOTO R2
+2 SET X=Y
KILL DIR,DTOUT,DIROUT,DIRUT
R4 SET ORDER=$SELECT(X="T":1,X="N":"",X="P":3,1:2)
+1 ;
RPL IF ORDER=3
Begin DoDot:1
+1 SET DIR("?")="Enter Physical Location to sort by. Must be an exact match"
+2 SET DIR("??")="Enter Physical Location to sort by. Must be an exact matchas this is a Free Text field."
+3 SET DIR(0)="F^1:25"
SET DIR("A")="ENTER PHYSICAL LOCATION TO SORT BY"
+4 SET DIR("B")="ALL"
DO ^DIR
End DoDot:1
+5 IF ORDER=3
IF Y<0!$DATA(DTOUT)!$DATA(DIROUT)!$DATA(DIRUT)
QUIT
+6 IF ORDER=3
SET SDPLSRT=X
+7 IF ORDER=3
IF $$PLVAL'=1
WRITE !,"Not an exact match!"
GOTO RPL
+8 IF ORDER=3
KILL DIR,DTOUT,DIROUT,DIRUT
+9 ;
+10 IF '$DATA(DT)
DO DT^SDUTL
SET %DT="AEXF"
SET %DT("A")="PRINT ROUTING SLIPS FOR WHAT DATE: "
DO ^%DT
KILL %DT("A")
IF Y<1
GOTO END
SET SDATE=Y
A5 SET %=2
WRITE !,"IS THIS A REPRINT OF A PREVIOUS RUN"
DO YN^DICN
IF '%
DO QQ
GOTO A5
+1 IF %<0
QUIT
IF '(%-1)
SET POP=0
DO REP^SDROUT1
IF POP
QUIT
+2 IF ORDER=2
IF SDREP=""
IF '$$CLINIC(DIV,.VAUTC)
GOTO END
+3 IF ORDER=3
IF SDREP=""
IF '$$CLINIC(DIV,.VAUTC)
GOTO END
+4 SET VAR="DIV^VAUTC^VAUTC(^SDX^ORDER^SDATE^SDIQ^SDREP^SDSTART^SDLOC^SDPLSRT"
+5 SET DGPGM="START^SDROUT"
+6 DO ZIS^DGUTQ
IF POP
GOTO END^SDROUT1
+7 GOTO START
START ;EP; IHS/ANMC/LJF 11/15/2000 called by BSDROUT to return to VA code
+1 ;IHS/ANMC/LJF 11/15/2000 IHS code uses ^TMP
KILL ^TMP("SDRS",$JOB)
+2 KILL ^UTILITY($JOB)
USE IO
+3 SET Y=SDATE
DO DTS^SDUTL
SET APDATE=Y
SET Y=DT
DO DTS^SDUTL
SET PRDATE=Y
+4 ;
+5 ;
+6 ;IHS/ANMC/LJF 11/15/2000 11/02/2001 changed $N to $O, added IHS call
+7 ;F SC=0:0 S SC=$N(^SC(SC)) Q:SC'>0 D CHECK I $T S GDATE=SDATE F K=0:0 S GDATE=$N(^SC(SC,"S",GDATE)) ;split line - too ling with semi-colon added
+8 ;Q:GDATE<0!(GDATE>(SDATE+1)) I $D(^SC(SC,"S",GDATE,1)) F L=0:0 S L=$N(^SC(SC,"S",GDATE,1,L)) Q:L<0 I $D(^(L,0)),$P(^(0),U,9)'="C" D GOT^SDROUT0
+9 SET SC=0
FOR
SET SC=$ORDER(^SC(SC))
IF 'SC
QUIT
DO CHECK
IF $TEST
Begin DoDot:1
+10 SET GDATE=SDATE
+11 FOR
SET GDATE=$ORDER(^SC(SC,"S",GDATE))
IF ('GDATE)!(GDATE>(SDATE+1))
QUIT
Begin DoDot:2
+12 IF $DATA(^SC(SC,"S",GDATE,1))
FOR L=0:0
SET L=$ORDER(^SC(SC,"S",GDATE,1,L))
IF 'L
QUIT
IF $DATA(^(L,0))
IF $PIECE(^(0),U,9)'="C"
DO FIND^BSDROUT0(SC,GDATE,L,ORDER,"")
End DoDot:2
End DoDot:1
+13 DO CRLOOP^BSDROUT2
+14 DO PRINT^BSDROUT1(ORDER,SDATE)
QUIT
+15 ;IHS/ANMC/LJF 11/15/2000 11/02/2001
+16 ;
+17 GOTO GO^SDROUT0
+18 ;IHS/ANMC/LJF 11/15/2000 file room list check added
CHECK ;I $P(^SC(SC,0),"^",3)="C",$S(DIV="":1,$P(^SC(SC,0),"^",15)=DIV:1,1:0),$S('$D(^SC(SC,"I")):1,+^("I")=0:1,+^("I")>SDATE:1,+$P(^("I"),"^",2)'>SDATE&(+$P(^("I"),"^",2)):1,1:0)
+1 IF $PIECE(^SC(SC,0),U,21)'=0
IF $PIECE(^SC(SC,0),"^",3)="C"
IF $SELECT(DIV="":1,$PIECE(^SC(SC,0),"^",15)=DIV:1,1:0)
IF $SELECT('$DATA(^SC(SC,"I")):1,+^("I")=0:1,+^("I")>SDATE:1,+$PIECE(^("I"),"^",2)'>SDATE&(+$PIECE(^("I"),"^",2)):1,1:0)
+2 IF $TEST
IF $SELECT(ORDER'=2:1,SDREP:1,VAUTC=1:1,1:$DATA(VAUTC(SC)))
+3 QUIT
QQ WRITE !,"RESPOND YES OR NO"
QUIT
END KILL VAUTC,ALL,DIV,ORD,ORDER,RMSEL,SDIQ,SDREP,SDSP,SDSTART,SDX,X,Y,C,V,I,SDEF,%I
QUIT
+1 ;
CLINIC(SDIV,VAUTC) ;
+1 NEW DIV,SDX,ORDER,SDATE,SDIQ,SDREP,SDSTART,VAUTD
+2 IF 'SDIV
SET VAUTD=1
+3 IF SDIV
SET VAUTD=0
SET VAUTD(SDIV)=$PIECE($GET(^DG(40.8,SDIV,0)),U)
+4 QUIT $$CLINIC1()
+5 ;
CLINIC1() ; -- get clinic data
+1 ; input: VAUTD := divisions selected
+2 ; output: VAUTC := clinic selected (VAUTC=1 for all)
+3 ; return: was selection made [ 1|yes 0|no]
+4 ;
+5 WRITE !!,$$LINE^SDAMO("Clinic Selection")
+6 ;
+7 ; -- select clinics
+8 ; -- call generic clinic screen, correct division
+9 ;
+10 SET DIC("S")="I $$CLINIC2^SDROUT(Y),$S(VAUTD:1,$D(VAUTD(+$P(^SC(Y,0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD(+$O(^DG(40.8,0)))):1,1:0)"
+11 SET DIC="^SC("
SET VAUTSTR="clinic"
SET VAUTVB="VAUTC"
SET VAUTNI=2
+12 DO FIRST^VAUTOMA
+13 ;
+14 IF Y<0
KILL VAUTC
CLINICQ QUIT $DATA(VAUTC)>0
+1 ;
CLINIC2(SDCL) ; -- generic screen for hos. loc. entries
+1 ; input: SDCL := ifn of HOSPITAL LOCATION file
+2 ; returned := [ 0 | do not use entry ; 1 | use entry ]
+3 ;
+4 ; -- must be a clinic
+5 NEW X
SET X=$GET(^SC(SDCL,0))
+6 QUIT $PIECE(X,"^",3)="C"
+7 ;
PLVAL() ; Physical Location Validation.
+1 NEW SDCLIN,SDPLOC
+2 SET SDMATCH=0
+3 IF SDPLSRT="ALL"
SET SDMATCH=1
QUIT SDMATCH
+4 SET SDCLIN=""
FOR
SET SDCLIN=$ORDER(^SC(SDCLIN))
IF SDCLIN=""!(SDMATCH=1)
QUIT
Begin DoDot:1
+5 SET SDPLOC=$PIECE($GET(^SC(SDCLIN,0)),"^",11)
+6 IF SDPLOC=SDPLSRT
SET SDMATCH=1
End DoDot:1
+7 QUIT SDMATCH
HELP WRITE !?12,"CHOOSE FROM:",!?12,"T - To see routing slips sorted in terminal digit order",!?12,"N - To see routing slips sorted in alphabetical order by name",!?12,"C - To see routing slips printed by clinic "
Begin DoDot:1
+1 WRITE !,?12,"or P - To see routing slip printed by physical location"
End DoDot:1
