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

LRAPDLG.m

Go to the documentation of this file.
  1. LRAPDLG ;SLC/JNM - LAB ANATOMIC PATHOLOGY ROUTINES ;Jun 30, 2022@16:42:50
  1. ;;5.2;LAB SERVICE;**553**;Feb 14, 1996;Build 21
  1. ;
  1. Q
  1. ;
  1. OK4CPRS(IEN) ; Returns True if the LAB test is allowed as an AP Dialog in CPRS
  1. ; IEN to the LABORATORY TEST File (#60)
  1. N OK,IDX,CIDX,LRSUB
  1. S OK=0
  1. ;
  1. I '$G(IEN) Q OK
  1. ;
  1. S LRSUB=$P($G(^LAB(60,IEN,0)),U,4)
  1. I LRSUB'?1(1"SP",1"CY",1"EM") Q OK
  1. ;
  1. I $P($G(^LAB(60,IEN,64)),U,1)="" Q OK
  1. ;
  1. I $D(^LAB(60,IEN)) D
  1. . S IDX=0 F S IDX=$O(^LAB(60,IEN,21661,IDX)) Q:'IDX D Q:OK
  1. . . S CIDX=+$P($G(^LAB(60,IEN,21661,IDX,0)),U) I CIDX,$P($G(^LAB(69.71,CIDX,0)),U,3)=1 S OK=1
  1. Q OK