LRAPDLG.m

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 ---LRAPDLG   628     printed  Apr 09, 2024@21:21:14                                                                                                                                                                                                      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