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 ---[H[J[2J[HLRBLSCRN 661 printed Dec 13, 2024@02:12:13 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
