LRAPDLG ;SLC/JNM - LAB ANATOMIC PATHOLOGY ROUTINES ;Jun 30, 2022@16:42:50
;;5.2;LAB SERVICE;**553**;Feb 14, 1996;Build 21
;
Q
;
OK4CPRS(IEN) ; Returns True if the LAB test is allowed as an AP Dialog in CPRS
; IEN to the LABORATORY TEST File (#60)
N OK,IDX,CIDX,LRSUB
S OK=0
;
I '$G(IEN) Q OK
;
S LRSUB=$P($G(^LAB(60,IEN,0)),U,4)
I LRSUB'?1(1"SP",1"CY",1"EM") Q OK
;
I $P($G(^LAB(60,IEN,64)),U,1)="" Q OK
;
I $D(^LAB(60,IEN)) D
. S IDX=0 F S IDX=$O(^LAB(60,IEN,21661,IDX)) Q:'IDX D Q:OK
. . 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
Q OK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPDLG 628 printed Nov 22, 2024@17:17:22 Page 2
LRAPDLG ;SLC/JNM - LAB ANATOMIC PATHOLOGY ROUTINES ;Jun 30, 2022@16:42:50
+1 ;;5.2;LAB SERVICE;**553**;Feb 14, 1996;Build 21
+2 ;
+3 QUIT
+4 ;
OK4CPRS(IEN) ; Returns True if the LAB test is allowed as an AP Dialog in CPRS
+1 ; IEN to the LABORATORY TEST File (#60)
+2 NEW OK,IDX,CIDX,LRSUB
+3 SET OK=0
+4 ;
+5 IF '$GET(IEN)
QUIT OK
+6 ;
+7 SET LRSUB=$PIECE($GET(^LAB(60,IEN,0)),U,4)
+8 IF LRSUB'?1(1"SP",1"CY",1"EM")
QUIT OK
+9 ;
+10 IF $PIECE($GET(^LAB(60,IEN,64)),U,1)=""
QUIT OK
+11 ;
+12 IF $DATA(^LAB(60,IEN))
Begin DoDot:1
+13 SET IDX=0
FOR
SET IDX=$ORDER(^LAB(60,IEN,21661,IDX))
if 'IDX
QUIT
Begin DoDot:2
+14 SET CIDX=+$PIECE($GET(^LAB(60,IEN,21661,IDX,0)),U)
IF CIDX
IF $PIECE($GET(^LAB(69.71,CIDX,0)),U,3)=1
SET OK=1
End DoDot:2
if OK
QUIT
End DoDot:1
+15 QUIT OK
