LRBLSCRN.m

LRBLSCRN ;DAL/MEA - BB DD FIELD SCREEN; ; 11/21/00 3:34pm

 ;;5.2;LAB SERVICE;**267**;Sep 27, 1994

 ;

PEDI() N X,Y,ANS,CODEX,CODEY

 S ANS=0

 S X=^(0)  ; From ^LAB(66,x,0)

 S Y=^LAB(66,DA,0)

 I $P(X,U,29) D

 .S CODEX=$P(X,U,5)

 .S CODEY=$P(Y,U,5)

 .I $E(CODEX,1,6)'=$E(CODEY,1,6) Q  ; Both have same base product code

 .I $E(CODEX,7)'="A" Q  ; Seventh character is an 'A' (split)

 .I $P(X,U,12)'=$P(Y,U,12) Q  ; Both have same anti coag

 .I $P(X,U,29)'=$P(Y,U,29) Q  ; Both are of the same symbology

 .S ANS=1  ; If ISBT, same coag, and same symbology

 I '$P(X,U,29),$P(X,U)["PEDIATRIC",$P(X,U,12)=$P(Y,U,12),$P(X,U,29)=$P(Y,U,29) S ANS=1

 Q ANS

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRBLSCRN   661     printed  Apr 09, 2024@21:18:26                                                                                                                                                                                                     Page 2

LRBLSCRN  ;DAL/MEA - BB DD FIELD SCREEN; ; 11/21/00 3:34pm

 +1       ;;5.2;LAB SERVICE;**267**;Sep 27, 1994

 +2       ;

PEDI()     NEW X,Y,ANS,CODEX,CODEY

 +1        SET ANS=0

 +2       ; From ^LAB(66,x,0)

           SET X=^(0)

 +3        SET Y=^LAB(66,DA,0)

 +4        IF $PIECE(X,U,29)

               Begin DoDot:1

 +5                SET CODEX=$PIECE(X,U,5)

 +6                SET CODEY=$PIECE(Y,U,5)

 +7       ; Both have same base product code

                   IF $EXTRACT(CODEX,1,6)'=$EXTRACT(CODEY,1,6)

                       QUIT 

 +8       ; Seventh character is an 'A' (split)

                   IF $EXTRACT(CODEX,7)'="A"

                       QUIT 

 +9       ; Both have same anti coag

                   IF $PIECE(X,U,12)'=$PIECE(Y,U,12)

                       QUIT 

 +10      ; Both are of the same symbology

                   IF $PIECE(X,U,29)'=$PIECE(Y,U,29)

                       QUIT 

 +11      ; If ISBT, same coag, and same symbology

                   SET ANS=1

               End DoDot:1

 +12       IF '$PIECE(X,U,29)

               IF $PIECE(X,U)["PEDIATRIC"

                   IF $PIECE(X,U,12)=$PIECE(Y,U,12)

                       IF $PIECE(X,U,29)=$PIECE(Y,U,29)

                           SET ANS=1

 +13       QUIT ANS