SDROUT ;BSN/GRR - ROUTING SLIPS ; 26 APR 84 11:26 am
;;5.3;Scheduling;**3,39,377**;Aug 13, 1993
N VAUTC,SDPLSRT,SDMATCH
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
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
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")
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 K ^UTILITY($J) U IO
S Y=SDATE D DTS^SDUTL S APDATE=Y,Y=DT D DTS^SDUTL S PRDATE=Y
F SC=0:0 S SC=$O(^SC(SC)) Q:SC<1 D CHECK I $T S GDATE=SDATE F K=0:0 S GDATE=$O(^SC(SC,"S",GDATE)) Q:GDATE<1!(GDATE>(SDATE+1)) I $D(^SC(SC,"S",GDATE,1)) F L=0:0 S L=$O(^SC(SC,"S",GDATE,1,L)) Q:L<1 I $D(^(L,0)),$P(^(0),U,9)'="C" D GOT^SDROUT0
G GO^SDROUT0
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 $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"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDROUT 4100 printed Dec 13, 2024@03:00:08 Page 2
SDROUT ;BSN/GRR - ROUTING SLIPS ; 26 APR 84 11:26 am
+1 ;;5.3;Scheduling;**3,39,377**;Aug 13, 1993
+2 NEW VAUTC,SDPLSRT,SDMATCH
+3 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 if %<0
GOTO END
SET SDSP=$SELECT(%=2:"N",1:"Y")
if SDSP["Y"
GOTO SIN1^SDROUT1
R2 READ !,"WANT (A)LL ROUTING SHEETS OR (O)NLY ADD-ONS: ONLY ADD-ONS// ",X:DTIME
if X["^"!('$TEST)
GOTO END
IF X=""
SET X="O"
WRITE X
+1 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
+2 SET SDX=$SELECT(X="O":"ADD-ONS",1:"ALL")
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 KILL ^UTILITY($JOB)
USE IO
+1 SET Y=SDATE
DO DTS^SDUTL
SET APDATE=Y
SET Y=DT
DO DTS^SDUTL
SET PRDATE=Y
+2 FOR SC=0:0
SET SC=$ORDER(^SC(SC))
if SC<1
QUIT
DO CHECK
IF $TEST
SET GDATE=SDATE
FOR K=0:0
SET GDATE=$ORDER(^SC(SC,"S",GDATE))
if GDATE<1!(GDATE>(SDATE+1))
QUIT
IF $DATA(^SC(SC,"S",GDATE,1))
FOR L=0:0
SET L=$ORDER(^SC(SC,"S",GDATE,1,L))
if L<1
QUIT
IF $DATA(^(L,0))
IF $PIECE(^(0),U,9)'="C"
DO GOT^SDROUT0
+3 GOTO GO^SDROUT0
CHECK 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)
+1 IF $TEST
IF $SELECT(ORDER'=2:1,SDREP:1,VAUTC=1:1,1:$DATA(VAUTC(SC)))
+2 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
