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

RAJAC.m

Go to the documentation of this file.
  1. RAJAC ;HISC/FPT,GJC AISC/MJK,RMO-Print Film Jacket Labels ;9/5/95 15:26
  1. ;;5.0;Radiology/Nuclear Medicine;**1,8,47**;Mar 16, 1998;Build 21
  1. START I '$D(RATEST) Q:'$D(^RADPT(RADFN,0)) S RAY1=^(0) Q:'$D(^DPT(RADFN,0)) S RAY0=^(0)
  1. S RAY2=$G(RASAV2),RAY3=$G(RASAV3) ;from RAREG3
  1. S (RADTI,RACNI)=0
  1. I $D(RAMDIV) S $P(RAY2,"^",3)=RAMDIV
  1. I $D(RATEST) D K RAK(0) ;p47
  1. .;w/P47 the LONG CASE NUMBER record in file 78.7 may be required to print
  1. .;a legacy LONG CASE NUMBER: 081194-234 or a LONG CASE NUMBER with a site
  1. .;prefix: 578-081194-234. RAI is the flag that determines the format to use.
  1. .;
  1. .F RAK=0:0 S RAK=$O(^RA(78.7,RAK)) Q:RAK'>0 I $D(^(RAK,0)) S RAK(0)=$G(^RA(78.7,RAK,0)) D
  1. ..I $P(RAK(0),U)="LONG CASE NUMBER" D LONGCASE^RAFLH2(RAK(0)) Q
  1. ..S @$P(RAK(0),U,5)=$P(RAK(0),U,4)
  1. ..Q
  1. .Q
  1. D PRT^RAFLH,CLOSE^RAUTL
  1. K RAY0,RAY1,RAY2,RAY3,RADFN,RADTI,RACNI,RATYPE,RAFMT,RANUM,RASAV2,RASAV3 F RAK=0:0 S RAK=$O(^RA(78.7,RAK)) Q:RAK'>0 I $D(^(RAK,0)) K @$P(^(0),"^",5)
  1. K RAK Q
  1. ;
  1. JAC ; Called from LABEL^RAREG3
  1. N RADTI
  1. S ION=$P(RAMLC,"^",5),IOP=$S(ION]"":"Q;"_ION,1:"Q")
  1. S:IOP="Q" RASELDEV="Select the JACKET LABEL Printer"
  1. S RANUM=$S($P(RAMLC,"^",4):$P(RAMLC,"^",4),1:1),RAFMT=$S($P(RAMLC,"^",11):$P(RAMLC,"^",11),1:1)
  1. ;
  1. ; NOTE: When the location parameter HOW MANY JACKET LABELS PER VISIT
  1. ; (File 79.1) equals zero AND the division parameter PRINT JACKET LABELS
  1. ; WITH EACH VISIT (File 79) equals YES, the RAPSET routine will set
  1. ; $P(RAMLC,U,4) equal to 2 (not zero).
  1. ;
  1. Q S ZTDTH=$H,ZTRTN="DQ^RAJAC" F RASV=$S($D(RATEST):"RATEST",1:"RADFN"),"RANUM","RAFMT","RAMDIV","RASAV*" S ZTSAVE(RASV)=""
  1. S:'$D(RAMES) RAMES="W !?5,""...all film jacket labels queued to print on "",ION,""."",!"
  1. W ! D ZIS^RAUTL G KILL:RAPOP
  1. ;
  1. DQ U IO S U="^" S X="T",%DT="" D ^%DT S DT=Y G START
  1. ;
  1. DUP D SET^RAPSET1 I $D(XQUIT) K XQUIT D KILL Q
  1. S DIC(0)="AEMQ" D ^RADPA G KILL:Y<0 S RADFN=+Y,ION=$P(RAMLC,"^",5),IOP=$S(ION]"":"Q;"_ION,1:"Q")
  1. S RAMES="W !!,""Duplicates queued to print on "",ION,"".""",RAFMT=$S($P(RAMLC,"^",11):$P(RAMLC,"^",11),1:1)
  1. FLH R !,"How many jacket labels? 1// ",X:DTIME G DUP:'$T!(X["^") S:X="" X=1 S RANUM=X I '(RANUM?.N)!(RANUM>20) W !?3,*7,"Must be a whole number less than 21!" G FLH
  1. K RAFL D Q,KILL W ! G DUP
  1. ;
  1. KILL K %,%W,%X,%Y,A,C,DIC,DUOUT,I,POP,RAFMT,RAMES,RANUM,RADFN,RAPOP,RASV,X,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,POP,DISYS,DFN Q