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

RABAR1.m

Go to the documentation of this file. 
  1. RABAR1 ;HISC/GJC-Procedure & CPT Code barcode output (part 2 of 2)
  1.  ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
  1.  ;
  1. PRINT ; Print the barcode(s) & CPT Code(s)
  1.  N RA71,RA792,D0,RASPACE S RASPACE="  "
  1.  S D0=RA2 ; D0 selected for FM compatibility
  1.  S RA71(0)=$G(^RAMIS(71,D0,0)),RA71(6)=$P(RA71(0),"^",6)
  1.  S RA71(9)=+$P(RA71(0),"^",9),RA71(12)=+$P(RA71(0),"^",12)
  1.  S RA71(6)=$$XTERNAL^RAUTL5(RA71(6),$P($G(^DD(71,6,0)),"^",2))
  1.  I RA71(9)>0 D
  1.  . S RA71(9)=$$XTERNAL^RAUTL5(RA71(9),$P($G(^DD(71,9,0)),"^",2))
  1.  . Q
  1.  E  S RA71(9)="No CPT"
  1.  S RA792(3)=$P($G(^RA(79.2,+RA71(12),0)),"^",3)
  1.  I $E(RAPRNT,1)="B" D
  1.  . I $Y>(IOSL-RAEOS) D  Q:RAXIT
  1.  .. S RAXIT=$$EOS^RAUTL5() Q:RAXIT
  1.  .. D HDR^RABAR
  1.  .. Q
  1.  . W !,$P(RA71(0),"^"),RASPACE,RA792(3),RASPACE,RA71(6),RASPACE,RA71(9)
  1.  . W ! X ^DD(71,15,9.1) D:$D(RAVHI) DOLLARY^RABAR
  1.  . I $Y>(IOSL-RAEOS) D  Q:RAXIT
  1.  .. S RAXIT=$$EOS^RAUTL5() Q:RAXIT
  1.  .. D HDR^RABAR
  1.  .. Q
  1.  . W !?10 X ^DD(71,16,9.1) W !
  1.  . D:$D(RAVHI) DOLLARY^RABAR
  1.  . Q
  1.  E  D
  1.  . I $Y>(IOSL-RAEOS) D  Q:RAXIT
  1.  .. S RAXIT=$$EOS^RAUTL5() Q:RAXIT
  1.  .. D HDR^RABAR
  1.  .. Q
  1.  . I $E(RAPRNT,1)="C" D
  1.  .. W !,$P(RA71(0),"^"),RASPACE,RA792(3),RASPACE,RA71(6),RASPACE,RA71(9)
  1.  .. W !?10 X ^DD(71,16,9.1) W !
  1.  .. Q
  1.  . I $E(RAPRNT,1)="P" D
  1.  .. W !,$P(RA71(0),"^"),RASPACE,RA792(3),RASPACE,RA71(6),RASPACE,RA71(9)
  1.  .. W ! X ^DD(71,15,9.1) W !
  1.  .. Q
  1.  . D:$D(RAVHI) DOLLARY^RABAR
  1.  . Q
  1.  Q
  1. PRINT1 ; Print the test barcode
  1.  N X S X="TEST BARCODE PRINT"
  1.  D LINE^RABAR
  1.  D PSET^%ZISP
  1.  I IOBARON]"",(IOBAROFF]"") D
  1.  . W !,X
  1.  . W @IOBARON,X,@IOBAROFF
  1.  . Q
  1.  D PKILL^%ZISP
  1.  D LINE^RABAR
  1.  Q
  1. PROC() ; Select the Procedure(s)
  1.  N RADIC,RAINPUT,RAQUIT,RAUTIL
  1.  S RADIC="^RAMIS(71,",RADIC(0)="QEAMZ",RADIC("A")="Select Procedure: "
  1.  S RADIC("S1")="N RAI S RAI=+$P($G(^RAMIS(71,+Y,0)),""^"",12)"
  1.  S RADIC("S2")=",RAI(""DT"")=$$INA^RABAR(+Y) "
  1.  S RADIC("S3")="I RAI,(RAI(""DT"")),($D(^TMP($J,""RA I-TYPE"",$P($G(^RA(79.2,RAI,0)),""^""))))"
  1.  S RADIC("S")=RADIC("S1")_RADIC("S2")_RADIC("S3")
  1.  S RAUTIL="RA PROC",RAINPUT=1
  1.  D:$E($G(RASORT),1)'="C" EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)
  1.  D:$E($G(RASORT),1)="C" EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT,9)
  1.  Q RAQUIT
  1. TEST() ; Does the user wish to print a test barcode.
  1.  ; Returns '1' if test print is requested, '0' if no test print
  1.  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."
  1.  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"
  1.  S DIR("?")="Enter 'Y'es to print a sample, 'N'o to continue without a sample."
  1.  S DIR("A")="height (in vertical lines) of the barcode? "
  1.  S DIR("B")="No" D ^DIR S Y=$S($D(DIRUT):-1,1:+Y)
  1.  D KILLDIR^RABAR
  1.  Q Y
  1. ZOSF(DX,DY) ; Called to execute ^%ZOSF("XY")
  1.  X ^%ZOSF("XY")
  1.  Q
  1. ZTSAVE ; Save off variable for ZTLOAD
  1.  N I
  1.  F I="RADT","RAPRNT","RAXIT","^TMP($J,""RA PROC""," D
  1.  . S ZTSAVE(I)=""
  1.  . Q
  1.  S:$D(RASORT) ZTSAVE("RASORT")=""
  1.  S:$D(RATEST) ZTSAVE("RATEST")=""
  1.  S:$D(RAVHI) ZTSAVE("RAVHI")=""
  1.  Q