RABAR1 ;HISC/GJC-Procedure & CPT Code barcode output (part 2 of 2)
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
;
PRINT ; Print the barcode(s) & CPT Code(s)
N RA71,RA792,D0,RASPACE S RASPACE=" "
S D0=RA2 ; D0 selected for FM compatibility
S RA71(0)=$G(^RAMIS(71,D0,0)),RA71(6)=$P(RA71(0),"^",6)
S RA71(9)=+$P(RA71(0),"^",9),RA71(12)=+$P(RA71(0),"^",12)
S RA71(6)=$$XTERNAL^RAUTL5(RA71(6),$P($G(^DD(71,6,0)),"^",2))
I RA71(9)>0 D
. S RA71(9)=$$XTERNAL^RAUTL5(RA71(9),$P($G(^DD(71,9,0)),"^",2))
. Q
E S RA71(9)="No CPT"
S RA792(3)=$P($G(^RA(79.2,+RA71(12),0)),"^",3)
I $E(RAPRNT,1)="B" D
. I $Y>(IOSL-RAEOS) D Q:RAXIT
.. S RAXIT=$$EOS^RAUTL5() Q:RAXIT
.. D HDR^RABAR
.. Q
. W !,$P(RA71(0),"^"),RASPACE,RA792(3),RASPACE,RA71(6),RASPACE,RA71(9)
. W ! X ^DD(71,15,9.1) D:$D(RAVHI) DOLLARY^RABAR
. I $Y>(IOSL-RAEOS) D Q:RAXIT
.. S RAXIT=$$EOS^RAUTL5() Q:RAXIT
.. D HDR^RABAR
.. Q
. W !?10 X ^DD(71,16,9.1) W !
. D:$D(RAVHI) DOLLARY^RABAR
. Q
E D
. I $Y>(IOSL-RAEOS) D Q:RAXIT
.. S RAXIT=$$EOS^RAUTL5() Q:RAXIT
.. D HDR^RABAR
.. Q
. I $E(RAPRNT,1)="C" D
.. W !,$P(RA71(0),"^"),RASPACE,RA792(3),RASPACE,RA71(6),RASPACE,RA71(9)
.. W !?10 X ^DD(71,16,9.1) W !
.. Q
. I $E(RAPRNT,1)="P" D
.. W !,$P(RA71(0),"^"),RASPACE,RA792(3),RASPACE,RA71(6),RASPACE,RA71(9)
.. W ! X ^DD(71,15,9.1) W !
.. Q
. D:$D(RAVHI) DOLLARY^RABAR
. Q
Q
PRINT1 ; Print the test barcode
N X S X="TEST BARCODE PRINT"
D LINE^RABAR
D PSET^%ZISP
I IOBARON]"",(IOBAROFF]"") D
. W !,X
. W @IOBARON,X,@IOBAROFF
. Q
D PKILL^%ZISP
D LINE^RABAR
Q
PROC() ; Select the Procedure(s)
N RADIC,RAINPUT,RAQUIT,RAUTIL
S RADIC="^RAMIS(71,",RADIC(0)="QEAMZ",RADIC("A")="Select Procedure: "
S RADIC("S1")="N RAI S RAI=+$P($G(^RAMIS(71,+Y,0)),""^"",12)"
S RADIC("S2")=",RAI(""DT"")=$$INA^RABAR(+Y) "
S RADIC("S3")="I RAI,(RAI(""DT"")),($D(^TMP($J,""RA I-TYPE"",$P($G(^RA(79.2,RAI,0)),""^""))))"
S RADIC("S")=RADIC("S1")_RADIC("S2")_RADIC("S3")
S RAUTIL="RA PROC",RAINPUT=1
D:$E($G(RASORT),1)'="C" EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)
D:$E($G(RASORT),1)="C" EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT,9)
Q RAQUIT
TEST() ; Does the user wish to print a test barcode.
; Returns '1' if test print is requested, '0' if no test print
W !,"To print barcoded procedure list, you will need to know the height (in",!,"vertical lines) of the barcode output on the printer to be used."
W ! D KILLDIR^RABAR S DIR(0)="YA",DIR("A",1)="Do you wish to print a sample barcode for the purpose of determining the"
S DIR("?")="Enter 'Y'es to print a sample, 'N'o to continue without a sample."
S DIR("A")="height (in vertical lines) of the barcode? "
S DIR("B")="No" D ^DIR S Y=$S($D(DIRUT):-1,1:+Y)
D KILLDIR^RABAR
Q Y
ZOSF(DX,DY) ; Called to execute ^%ZOSF("XY")
X ^%ZOSF("XY")
Q
ZTSAVE ; Save off variable for ZTLOAD
N I
F I="RADT","RAPRNT","RAXIT","^TMP($J,""RA PROC""," D
. S ZTSAVE(I)=""
. Q
S:$D(RASORT) ZTSAVE("RASORT")=""
S:$D(RATEST) ZTSAVE("RATEST")=""
S:$D(RAVHI) ZTSAVE("RAVHI")=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRABAR1 3086 printed Apr 09, 2024@21:38:35 Page 2
RABAR1 ;HISC/GJC-Procedure & CPT Code barcode output (part 2 of 2)
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+2 ;
PRINT ; Print the barcode(s) & CPT Code(s)
+1 NEW RA71,RA792,D0,RASPACE
SET RASPACE=" "
+2 ; D0 selected for FM compatibility
SET D0=RA2
+3 SET RA71(0)=$GET(^RAMIS(71,D0,0))
SET RA71(6)=$PIECE(RA71(0),"^",6)
+4 SET RA71(9)=+$PIECE(RA71(0),"^",9)
SET RA71(12)=+$PIECE(RA71(0),"^",12)
+5 SET RA71(6)=$$XTERNAL^RAUTL5(RA71(6),$PIECE($GET(^DD(71,6,0)),"^",2))
+6 IF RA71(9)>0
Begin DoDot:1
+7 SET RA71(9)=$$XTERNAL^RAUTL5(RA71(9),$PIECE($GET(^DD(71,9,0)),"^",2))
+8 QUIT
End DoDot:1
+9 IF '$TEST
SET RA71(9)="No CPT"
+10 SET RA792(3)=$PIECE($GET(^RA(79.2,+RA71(12),0)),"^",3)
+11 IF $EXTRACT(RAPRNT,1)="B"
Begin DoDot:1
+12 IF $Y>(IOSL-RAEOS)
Begin DoDot:2
+13 SET RAXIT=$$EOS^RAUTL5()
if RAXIT
QUIT
+14 DO HDR^RABAR
+15 QUIT
End DoDot:2
if RAXIT
QUIT
+16 WRITE !,$PIECE(RA71(0),"^"),RASPACE,RA792(3),RASPACE,RA71(6),RASPACE,RA71(9)
+17 WRITE !
XECUTE ^DD(71,15,9.1)
if $DATA(RAVHI)
DO DOLLARY^RABAR
+18 IF $Y>(IOSL-RAEOS)
Begin DoDot:2
+19 SET RAXIT=$$EOS^RAUTL5()
if RAXIT
QUIT
+20 DO HDR^RABAR
+21 QUIT
End DoDot:2
if RAXIT
QUIT
+22 WRITE !?10
XECUTE ^DD(71,16,9.1)
WRITE !
+23 if $DATA(RAVHI)
DO DOLLARY^RABAR
+24 QUIT
End DoDot:1
+25 IF '$TEST
Begin DoDot:1
+26 IF $Y>(IOSL-RAEOS)
Begin DoDot:2
+27 SET RAXIT=$$EOS^RAUTL5()
if RAXIT
QUIT
+28 DO HDR^RABAR
+29 QUIT
End DoDot:2
if RAXIT
QUIT
+30 IF $EXTRACT(RAPRNT,1)="C"
Begin DoDot:2
+31 WRITE !,$PIECE(RA71(0),"^"),RASPACE,RA792(3),RASPACE,RA71(6),RASPACE,RA71(9)
+32 WRITE !?10
XECUTE ^DD(71,16,9.1)
WRITE !
+33 QUIT
End DoDot:2
+34 IF $EXTRACT(RAPRNT,1)="P"
Begin DoDot:2
+35 WRITE !,$PIECE(RA71(0),"^"),RASPACE,RA792(3),RASPACE,RA71(6),RASPACE,RA71(9)
+36 WRITE !
XECUTE ^DD(71,15,9.1)
WRITE !
+37 QUIT
End DoDot:2
+38 if $DATA(RAVHI)
DO DOLLARY^RABAR
+39 QUIT
End DoDot:1
+40 QUIT
PRINT1 ; Print the test barcode
+1 NEW X
SET X="TEST BARCODE PRINT"
+2 DO LINE^RABAR
+3 DO PSET^%ZISP
+4 IF IOBARON]""
IF (IOBAROFF]"")
Begin DoDot:1
+5 WRITE !,X
+6 WRITE @IOBARON,X,@IOBAROFF
+7 QUIT
End DoDot:1
+8 DO PKILL^%ZISP
+9 DO LINE^RABAR
+10 QUIT
PROC() ; Select the Procedure(s)
+1 NEW RADIC,RAINPUT,RAQUIT,RAUTIL
+2 SET RADIC="^RAMIS(71,"
SET RADIC(0)="QEAMZ"
SET RADIC("A")="Select Procedure: "
+3 SET RADIC("S1")="N RAI S RAI=+$P($G(^RAMIS(71,+Y,0)),""^"",12)"
+4 SET RADIC("S2")=",RAI(""DT"")=$$INA^RABAR(+Y) "
+5 SET RADIC("S3")="I RAI,(RAI(""DT"")),($D(^TMP($J,""RA I-TYPE"",$P($G(^RA(79.2,RAI,0)),""^""))))"
+6 SET RADIC("S")=RADIC("S1")_RADIC("S2")_RADIC("S3")
+7 SET RAUTIL="RA PROC"
SET RAINPUT=1
+8 if $EXTRACT($GET(RASORT),1)'="C"
DO EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)
+9 if $EXTRACT($GET(RASORT),1)="C"
DO EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT,9)
+10 QUIT RAQUIT
TEST() ; Does the user wish to print a test barcode.
+1 ; Returns '1' if test print is requested, '0' if no test print
+2 WRITE !,"To print barcoded procedure list, you will need to know the height (in",!,"vertical lines) of the barcode output on the printer to be used."
+3 WRITE !
DO KILLDIR^RABAR
SET DIR(0)="YA"
SET DIR("A",1)="Do you wish to print a sample barcode for the purpose of determining the"
+4 SET DIR("?")="Enter 'Y'es to print a sample, 'N'o to continue without a sample."
+5 SET DIR("A")="height (in vertical lines) of the barcode? "
+6 SET DIR("B")="No"
DO ^DIR
SET Y=$SELECT($DATA(DIRUT):-1,1:+Y)
+7 DO KILLDIR^RABAR
+8 QUIT Y
ZOSF(DX,DY) ; Called to execute ^%ZOSF("XY")
+1 XECUTE ^%ZOSF("XY")
+2 QUIT
ZTSAVE ; Save off variable for ZTLOAD
+1 NEW I
+2 FOR I="RADT","RAPRNT","RAXIT","^TMP($J,""RA PROC"","
Begin DoDot:1
+3 SET ZTSAVE(I)=""
+4 QUIT
End DoDot:1
+5 if $DATA(RASORT)
SET ZTSAVE("RASORT")=""
+6 if $DATA(RATEST)
SET ZTSAVE("RATEST")=""
+7 if $DATA(RAVHI)
SET ZTSAVE("RAVHI")=""
+8 QUIT
