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