- 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 Jan 18, 2025@03:08 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