RAFLH1 ;HISC/CAH,FPT AISC/MJK,RMO-Print Radiology Exam Labels ;6/12/97 11:44
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
Q:'RAEXLBLS I RAFLHFL S RACNI=RAFLHFL G PRT
F RACNI=+$P(RAFLHFL,";",2):0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 I $D(^(RACNI,0)) S RAY3=^(0) D PRT
Q
PRT S RAFMT=RAEXFM,RANUM=RAEXLBLS D PRT^RAFLH Q
;
TEST D SET^RAPSET1 I $D(XQUIT) K XQUIT,POP Q
S RATEST="",RANUM=1,RAFMT=$S($P(RAMLC,"^",7):$P(RAMLC,"^",7),1:1)
S ZTRTN="START^RAFLH1" F RASV="RATEST","RANUM","RAFMT","RAMDIV" S ZTSAVE(RASV)=""
D ZIS^RAUTL G Q:RAPOP
START U IO S RAK=0
F S RAK=$O(^RA(78.7,RAK)) Q:RAK'>0 D SETFLH^RAFLH2(RAK)
G Q:'$D(^RA(78.2,RAFMT,0))
F RAII=1:1:RANUM W @IOF F RAI=0:0 S RAI=$O(^RA(78.2,RAFMT,"E",RAI)) Q:RAI'>0 D
. I $G(^RA(78.2,RAFMT,"E",RAI,0))'["@" D
.. X ^RA(78.2,RAFMT,"E",RAI,0)
.. Q
. E D XECFLH^RAFLH2(RAFMT,RAI)
. Q
Q ; Quit & kill
; RAOPT("RPTPAT") is defined in the entry action field for options
; in this case RAOPT("RPTPAT") is defined for the option RA RPTPAT.
; RA RPTPAT is allowed to print more than one record. If multiple
; records, this CLOSE^RAUTL will close the device after printing
; only one record. This causes subsequent records to be displayed to
; the HOME device.
D:'$D(RAOPT("RPTPAT")) CLOSE^RAUTL S RAK=0
F S RAK=$O(^RA(78.7,RAK)) Q:RAK'>0 D KILFLH^RAFLH2(RAK)
K %W,%Y1,DUOUT,POP,RAEXFM,RAEXLBLS,RAFLHFL,RAFMT,RAI,RAII,RAK,RAMES,RANUM,RAPOP,RASV,RATEST,RAY0,RAY1,RAY2,RAY3,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,DISYS
I $D(ZTQUEUED) K RADFN,RADTI,RAFLH
Q
;
CMP ;This code compiles flash card formats into code stored in the
;'Compiled Logic' field #100 of file #78.2
Q:'$D(^RA(78.2,RAFMT,0)) S RAROW=$S($P(^(0),"^",2):$P(^(0),"^",2),1:6) K ^RA(78.2,RAFMT,"E"),^TMP($J,"RAFORM")
F RAI=0:0 S RAI=$O(^RA(78.2,RAFMT,1,RAI)) Q:RAI'>0 I $D(^(RAI,0)) S XX=^(0),^TMP($J,"RAFORM",+$P(XX,"^",2),+$P(XX,"^",3),$P(XX,"^"))=$P(XX,"^",4,5)
S RAN=1 F RAI=1:1:RAROW S FL=1 S:'$D(^TMP($J,"RAFORM",RAI)) ^RA(78.2,RAFMT,"E",RAN,0)="W !",RAN=RAN+1 I $D(^(RAI)) F COL=0:0 S COL=$O(^TMP($J,"RAFORM",RAI,COL)) Q:COL'>0 S %="",%=$O(^(COL,%)) S J=^(%) D STORE
W !!?5,"...format '",$P(^RA(78.2,RAFMT,0),"^"),"' has been compiled."
K RA787,RAROW,XX,RAI,RAII,RAIV,RADEF,J,TITL,COL,RAN,^TMP($J,"RAFORM")
Q
;
STORE S RAIV="DT",RADEF="" S:$D(^RA(78.7,+%,0)) RAIV=^(0),RADEF=$P(RAIV,"^",3),RAIV=$P(RAIV,"^",5)
S RA787("E")=$G(^RA(78.7,+%,"E"))
S TITL=$S(RAIV="RAFREE":"",$P(J,"^")="NONE":"",$P(J,"^")]"":$P(J,"^"),1:RADEF)
S ^RA(78.2,RAFMT,"E",RAN,0)="W "_$S(FL:"!",1:"")_"?"_(COL-1)_","""_TITL_""","_$S(RAIV="RAFREE":""""_$P(J,"^",2)_"""",RA787("E")["$$BCDE^RAUTL18":"@"_RAIV,1:RAIV)
S RAN=RAN+1,FL=0
Q
;
; Exam labels are printed on the device specified in the location
; parameter, FLASH CARD PRINTER NAME in File 79.1. If there is no
; value in that field, the user will be prompted for a device. The
; number of exam labels printed is defined in the location parameter,
; HOW MANY EXAM LABELS PER EXAM. That number is not changed by any
; parameter or combination of parameters. If that number is zero (or
; null), then no exam labels will be printed.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAFLH1 3189 printed Dec 13, 2024@02:35:08 Page 2
RAFLH1 ;HISC/CAH,FPT AISC/MJK,RMO-Print Radiology Exam Labels ;6/12/97 11:44
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+2 if 'RAEXLBLS
QUIT
IF RAFLHFL
SET RACNI=RAFLHFL
GOTO PRT
+3 FOR RACNI=+$PIECE(RAFLHFL,";",2):0
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
if RACNI'>0
QUIT
IF $DATA(^(RACNI,0))
SET RAY3=^(0)
DO PRT
+4 QUIT
PRT SET RAFMT=RAEXFM
SET RANUM=RAEXLBLS
DO PRT^RAFLH
QUIT
+1 ;
TEST DO SET^RAPSET1
IF $DATA(XQUIT)
KILL XQUIT,POP
QUIT
+1 SET RATEST=""
SET RANUM=1
SET RAFMT=$SELECT($PIECE(RAMLC,"^",7):$PIECE(RAMLC,"^",7),1:1)
+2 SET ZTRTN="START^RAFLH1"
FOR RASV="RATEST","RANUM","RAFMT","RAMDIV"
SET ZTSAVE(RASV)=""
+3 DO ZIS^RAUTL
if RAPOP
GOTO Q
START USE IO
SET RAK=0
+1 FOR
SET RAK=$ORDER(^RA(78.7,RAK))
if RAK'>0
QUIT
DO SETFLH^RAFLH2(RAK)
+2 if '$DATA(^RA(78.2,RAFMT,0))
GOTO Q
+3 FOR RAII=1:1:RANUM
WRITE @IOF
FOR RAI=0:0
SET RAI=$ORDER(^RA(78.2,RAFMT,"E",RAI))
if RAI'>0
QUIT
Begin DoDot:1
+4 IF $GET(^RA(78.2,RAFMT,"E",RAI,0))'["@"
Begin DoDot:2
+5 XECUTE ^RA(78.2,RAFMT,"E",RAI,0)
+6 QUIT
End DoDot:2
+7 IF '$TEST
DO XECFLH^RAFLH2(RAFMT,RAI)
+8 QUIT
End DoDot:1
Q ; Quit & kill
+1 ; RAOPT("RPTPAT") is defined in the entry action field for options
+2 ; in this case RAOPT("RPTPAT") is defined for the option RA RPTPAT.
+3 ; RA RPTPAT is allowed to print more than one record. If multiple
+4 ; records, this CLOSE^RAUTL will close the device after printing
+5 ; only one record. This causes subsequent records to be displayed to
+6 ; the HOME device.
+7 if '$DATA(RAOPT("RPTPAT"))
DO CLOSE^RAUTL
SET RAK=0
+8 FOR
SET RAK=$ORDER(^RA(78.7,RAK))
if RAK'>0
QUIT
DO KILFLH^RAFLH2(RAK)
+9 KILL %W,%Y1,DUOUT,POP,RAEXFM,RAEXLBLS,RAFLHFL,RAFMT,RAI,RAII,RAK,RAMES,RANUM,RAPOP,RASV,RATEST,RAY0,RAY1,RAY2,RAY3,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,DISYS
+10 IF $DATA(ZTQUEUED)
KILL RADFN,RADTI,RAFLH
+11 QUIT
+12 ;
CMP ;This code compiles flash card formats into code stored in the
+1 ;'Compiled Logic' field #100 of file #78.2
+2 if '$DATA(^RA(78.2,RAFMT,0))
QUIT
SET RAROW=$SELECT($PIECE(^(0),"^",2):$PIECE(^(0),"^",2),1:6)
KILL ^RA(78.2,RAFMT,"E"),^TMP($JOB,"RAFORM")
+3 FOR RAI=0:0
SET RAI=$ORDER(^RA(78.2,RAFMT,1,RAI))
if RAI'>0
QUIT
IF $DATA(^(RAI,0))
SET XX=^(0)
SET ^TMP($JOB,"RAFORM",+$PIECE(XX,"^",2),+$PIECE(XX,"^",3),$PIECE(XX,"^"))=$PIECE(XX,"^",4,5)
+4 SET RAN=1
FOR RAI=1:1:RAROW
SET FL=1
if '$DATA(^TMP($JOB,"RAFORM",RAI))
SET ^RA(78.2,RAFMT,"E",RAN,0)="W !"
SET RAN=RAN+1
IF $DATA(^(RAI))
FOR COL=0:0
SET COL=$ORDER(^TMP($JOB,"RAFORM",RAI,COL))
if COL'>0
QUIT
SET %=""
SET %=$ORDER(^(COL,%))
SET J=^(%)
DO STORE
+5 WRITE !!?5,"...format '",$PIECE(^RA(78.2,RAFMT,0),"^"),"' has been compiled."
+6 KILL RA787,RAROW,XX,RAI,RAII,RAIV,RADEF,J,TITL,COL,RAN,^TMP($JOB,"RAFORM")
+7 QUIT
+8 ;
STORE SET RAIV="DT"
SET RADEF=""
if $DATA(^RA(78.7,+%,0))
SET RAIV=^(0)
SET RADEF=$PIECE(RAIV,"^",3)
SET RAIV=$PIECE(RAIV,"^",5)
+1 SET RA787("E")=$GET(^RA(78.7,+%,"E"))
+2 SET TITL=$SELECT(RAIV="RAFREE":"",$PIECE(J,"^")="NONE":"",$PIECE(J,"^")]"":$PIECE(J,"^"),1:RADEF)
+3 SET ^RA(78.2,RAFMT,"E",RAN,0)="W "_$SELECT(FL:"!",1:"")_"?"_(COL-1)_","""_TITL_""","_$SELECT(RAIV="RAFREE":""""_$PIECE(J,"^",2)_"""",RA787("E")["$$BCDE^RAUTL18":"@"_RAIV,1:RAIV)
+4 SET RAN=RAN+1
SET FL=0
+5 QUIT
+6 ;
+7 ; Exam labels are printed on the device specified in the location
+8 ; parameter, FLASH CARD PRINTER NAME in File 79.1. If there is no
+9 ; value in that field, the user will be prompted for a device. The
+10 ; number of exam labels printed is defined in the location parameter,
+11 ; HOW MANY EXAM LABELS PER EXAM. That number is not changed by any
+12 ; parameter or combination of parameters. If that number is zero (or
+13 ; null), then no exam labels will be printed.
