Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDROUT

SDROUT.m

Go to the documentation of this file. 
  1. 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
  1.  ;IHS/ANMC/LJF 11/15/2000 added IHS call for sorts & reprint questions
  1.  ;                        added kill of ^TMP (used instead of ^UTILITY)
  1.  ;                        changed $N to $O
  1.  ;                        checked for "include on file room list=no"
  1.  ;             11/17/2000 added IHS call for single patient rs
  1.  ;             11/22/2000 added call to find chart requests to print
  1.  ;             12/06/2000 made all vs. add-on question clearer
  1.  ;             11/02/2001 added code to print range for ALL
  1.  ;ihs/cmi/maw  04/11/2011 PATCH 1013 RQMT151
  1.  ;
  1.  N VAUTC,SDPLSRT,SDMATCH
  1.  S SDSTOP=""   ;IHS/ANMC/LJF 11/02/2001
  1.  S (SDIQ,SDX,DIV,SDREP,SDSTART)="" D DIV^SDUTL I $T D ROUT^SDDIV G:Y<0 END
  1. R1 S %=2 W !,"DO YOU WANT ROUTING SHEET FOR A SINGLE PATIENT" D YN^DICN I '% D QQ G R1
  1.  ;G:%<0 END S SDSP=$S(%=2:"N",1:"Y") G:SDSP["Y" SIN1^SDROUT1
  1.  G:%<0 END S SDSP=$S(%=2:"N",1:"Y") G:SDSP["Y" ONE^BSDROUT  ;IHS/ANMC/LJF 11/17/2000
  1. 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
  1.  N BSDRSDF,BSDPROM
  1.  S BSDRSDF=$S($G(DIV):$$GET1^DIQ(9009020.2,DIV,.27,"I"),1:"O")
  1.  ;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
  1.  S DIR(0)="S^A:All Routing Slips;O:Only Add-Ons",DIR("A")="Select All Routing Slips (A) or Only Add-ons (O): "
  1.  S DIR("B")=BSDRSDF
  1.  D ^DIR
  1.  G END:$D(DIRUT)
  1.  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
  1.  S SDX=$S(X="O":"ADD-ONS",1:"ALL")
  1.  ;
  1.  D ASK^BSDROUT Q  ;IHS/ANMC/LJF 11/15/2000
  1.  ;
  1. 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
  1.  G:Y<0!$D(DTOUT)!$D(DIROUT)!$D(DIRUT) R2
  1.  S X=Y K DIR,DTOUT,DIROUT,DIRUT
  1. R4 S ORDER=$S(X="T":1,X="N":"",X="P":3,1:2)
  1.  ;
  1. RPL I ORDER=3 D
  1.  .S DIR("?")="Enter Physical Location to sort by. Must be an exact match"
  1.  .S DIR("??")="Enter Physical Location to sort by. Must be an exact matchas this is a Free Text field."
  1.  .S DIR(0)="F^1:25",DIR("A")="ENTER PHYSICAL LOCATION TO SORT BY"
  1.  .S DIR("B")="ALL" D ^DIR
  1.  I ORDER=3,Y<0!$D(DTOUT)!$D(DIROUT)!$D(DIRUT) Q
  1.  I ORDER=3 S SDPLSRT=X
  1.  I ORDER=3,$$PLVAL'=1 W !,"Not an exact match!" G RPL
  1.  I ORDER=3 K DIR,DTOUT,DIROUT,DIRUT
  1.  ;
  1.  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
  1. A5 S %=2 W !,"IS THIS A REPRINT OF A PREVIOUS RUN" D YN^DICN I '% D QQ G A5
  1.  Q:%<0  I '(%-1) S POP=0 D REP^SDROUT1 Q:POP
  1.  I ORDER=2,SDREP="" G END:'$$CLINIC(DIV,.VAUTC)
  1.  I ORDER=3,SDREP="" G END:'$$CLINIC(DIV,.VAUTC)
  1.  S VAR="DIV^VAUTC^VAUTC(^SDX^ORDER^SDATE^SDIQ^SDREP^SDSTART^SDLOC^SDPLSRT"
  1.  S DGPGM="START^SDROUT"
  1.  D ZIS^DGUTQ G:POP END^SDROUT1
  1.  G START
  1. START ;EP; IHS/ANMC/LJF 11/15/2000 called by BSDROUT to return to VA code
  1.  K ^TMP("SDRS",$J)  ;IHS/ANMC/LJF 11/15/2000 IHS code uses ^TMP
  1.  K ^UTILITY($J) U IO
  1.  S Y=SDATE D DTS^SDUTL S APDATE=Y,Y=DT D DTS^SDUTL S PRDATE=Y
  1.  ;
  1.  ;
  1.  ;IHS/ANMC/LJF 11/15/2000 11/02/2001 changed $N to $O, added IHS call
  1.  ;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
  1.  ;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
  1.  S SC=0 F  S SC=$O(^SC(SC)) Q:'SC  D CHECK I $T D
  1.  . S GDATE=SDATE
  1.  . F  S GDATE=$O(^SC(SC,"S",GDATE)) Q:('GDATE)!(GDATE>(SDATE+1))  D
  1.  .. 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,"")
  1.  D CRLOOP^BSDROUT2
  1.  D PRINT^BSDROUT1(ORDER,SDATE) Q
  1.  ;IHS/ANMC/LJF 11/15/2000 11/02/2001
  1.  ;
  1.  G GO^SDROUT0
  1.  ;IHS/ANMC/LJF 11/15/2000 file room list check added
  1. 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.  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)
  1.  I $T,$S(ORDER'=2:1,SDREP:1,VAUTC=1:1,1:$D(VAUTC(SC)))
  1.  Q
  1. QQ W !,"RESPOND YES OR NO" Q
  1. END K VAUTC,ALL,DIV,ORD,ORDER,RMSEL,SDIQ,SDREP,SDSP,SDSTART,SDX,X,Y,C,V,I,SDEF,%I Q
  1.  ;
  1. CLINIC(SDIV,VAUTC) ;
  1.  N DIV,SDX,ORDER,SDATE,SDIQ,SDREP,SDSTART,VAUTD
  1.  I 'SDIV S VAUTD=1
  1.  I SDIV S VAUTD=0,VAUTD(SDIV)=$P($G(^DG(40.8,SDIV,0)),U)
  1.  Q $$CLINIC1()
  1.  ;
  1. CLINIC1() ; -- get clinic data
  1.  ;  input: VAUTD  := divisions selected
  1.  ; output: VAUTC := clinic selected (VAUTC=1 for all)
  1.  ; return: was selection made [ 1|yes   0|no]
  1.  ;
  1.  W !!,$$LINE^SDAMO("Clinic Selection")
  1.  ;
  1.  ; -- select clinics
  1.  ; -- call generic clinic screen, correct division
  1.  ;
  1.  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)"
  1.  S DIC="^SC(",VAUTSTR="clinic",VAUTVB="VAUTC",VAUTNI=2
  1.  D FIRST^VAUTOMA
  1.  ;
  1.  I Y<0 K VAUTC
  1. CLINICQ Q $D(VAUTC)>0
  1.  ;
  1. CLINIC2(SDCL) ; -- generic screen for hos. loc. entries
  1.  ; input:   SDCL := ifn of HOSPITAL LOCATION file
  1.  ;      returned := [ 0 | do not use entry ; 1 | use entry ]
  1.  ;
  1.  ; -- must be a clinic
  1.  N X S X=$G(^SC(SDCL,0))
  1.  Q $P(X,"^",3)="C"
  1.  ;
  1. PLVAL() ; Physical Location Validation.
  1.  N SDCLIN,SDPLOC
  1.  S SDMATCH=0
  1.  I SDPLSRT="ALL" S SDMATCH=1 Q SDMATCH
  1.  S SDCLIN="" F  S SDCLIN=$O(^SC(SDCLIN)) Q:SDCLIN=""!(SDMATCH=1)  D
  1.  .S SDPLOC=$P($G(^SC(SDCLIN,0)),"^",11)
  1.  .I SDPLOC=SDPLSRT S SDMATCH=1
  1.  Q SDMATCH
  1. 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
  1.  .W !,?12,"or P - To see routing slip printed by physical location"