LR7OV3 ;slc/dcm - Update file 60 with Blood Component Request (66.9) ;8/11/97
;;5.2;LAB SERVICE;**121**;Sep 27, 1994
;
EN ;Start here to load Blood Product Requests from file 66.9
N IFN,IFN1,IFN2,X,X1,Y,SPEC,CTR,LAST,DIK,DA,EDIT,RCOM
I $O(^LAB(60,"B","TRANSFUSION REQUEST",0)) S X=$O(^(0)),SPEC=$P(^LAB(60,X,0),"^",9)
I '$G(SPEC) S SPEC=$O(^LAB(62,"B","BLOOD",0))
S EDIT=$O(^LAB(62.07,"B","LRBLSCREEN",0)),RCOM=$O(^LAB(62.07,"B","TRANSFUSION",0))
LOCK L +^LAB(60):360 G:'$T LOCK
S IFN=0,LAST=$P(^LAB(60,0),"^",3,4) F S IFN=$O(^LAB(66.9,IFN)) Q:IFN<1 S X=^(IFN,0) I '$D(^LAB(60,"B",$P(X,"^"))) D
. S IFN1=$S(+$P(^LAB(60,0),"^",3)<1100:+$P(^(0),"^",3),1:1100) F Q:'$D(^LAB(60,IFN1)) S IFN1=IFN1+1
. S LAST=(+IFN1)_"^"_($P(LAST,"^",2)+1)
. S ^LAB(60,IFN1,0)=$P(X,"^")_"^^I^BB^^^^1^"_SPEC_"^^^^^"_EDIT_"^^1^0^9^"_RCOM,^(.1)="BP-"_$E($P(X,"^"),1,4),^(12)=IFN I SPEC S ^(3,0)="^60.03PAI^1^1",^(1,0)=SPEC_"^^^10",^LAB(60,IFN1,3,"AB",SPEC,1)="",^LAB(60,IFN1,3,"B",SPEC,1)=""
. I $G(DUZ(2)) S ^LAB(60,IFN1,8,0)="^60.11PA^"_DUZ(2)_"^1",^LAB(60,IFN1,8,DUZ(2),0)=DUZ(2)_"^"_$O(^LRO(68,"B","BLOOD BANK",0))
. S DA=IFN1,DIK="^LAB(60," D IX^DIK
S $P(^LAB(60,0),"^",3,4)=LAST L -^LAB(60)
Q
DEL ;Delete components out of file 60 (for testing only)
N IFN,X,DA,DIK
S IFN=0 F S IFN=$O(^LAB(60,IFN)) Q:IFN<1 I $D(^(IFN,12)),+^(12) S DA=IFN,DIK="^LAB(60," D ^DIK W "."
Q
POS ;Post init for future blood bank patch, when/if ordering components
N LRCHK
S LRCHK=$$NEWCP^XPDUTL("P1","P1^LR7OV3")
Q
P1 ;Post init entry point
D BMES^XPDUTL("Now adding Blood Component Requests to Lab Test file...")
D EN
D MES^XPDUTL("Done adding Blood Component Requests")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OV3 1691 printed Apr 09, 2024@21:25:42 Page 2
LR7OV3 ;slc/dcm - Update file 60 with Blood Component Request (66.9) ;8/11/97
+1 ;;5.2;LAB SERVICE;**121**;Sep 27, 1994
+2 ;
EN ;Start here to load Blood Product Requests from file 66.9
+1 NEW IFN,IFN1,IFN2,X,X1,Y,SPEC,CTR,LAST,DIK,DA,EDIT,RCOM
+2 IF $ORDER(^LAB(60,"B","TRANSFUSION REQUEST",0))
SET X=$ORDER(^(0))
SET SPEC=$PIECE(^LAB(60,X,0),"^",9)
+3 IF '$GET(SPEC)
SET SPEC=$ORDER(^LAB(62,"B","BLOOD",0))
+4 SET EDIT=$ORDER(^LAB(62.07,"B","LRBLSCREEN",0))
SET RCOM=$ORDER(^LAB(62.07,"B","TRANSFUSION",0))
LOCK LOCK +^LAB(60):360
if '$TEST
GOTO LOCK
+1 SET IFN=0
SET LAST=$PIECE(^LAB(60,0),"^",3,4)
FOR
SET IFN=$ORDER(^LAB(66.9,IFN))
if IFN<1
QUIT
SET X=^(IFN,0)
IF '$DATA(^LAB(60,"B",$PIECE(X,"^")))
Begin DoDot:1
+2 SET IFN1=$SELECT(+$PIECE(^LAB(60,0),"^",3)<1100:+$PIECE(^(0),"^",3),1:1100)
FOR
if '$DATA(^LAB(60,IFN1))
QUIT
SET IFN1=IFN1+1
+3 SET LAST=(+IFN1)_"^"_($PIECE(LAST,"^",2)+1)
+4 SET ^LAB(60,IFN1,0)=$PIECE(X,"^")_"^^I^BB^^^^1^"_SPEC_"^^^^^"_EDIT_"^^1^0^9^"_RCOM
SET ^(.1)="BP-"_$EXTRACT($PIECE(X,"^"),1,4)
SET ^(12)=IFN
IF SPEC
SET ^(3,0)="^60.03PAI^1^1"
SET ^(1,0)=SPEC_"^^^10"
SET ^LAB(60,IFN1,3,"AB",SPEC,1)=""
SET ^LAB(60,IFN1,3,"B",SPEC,1)=""
+5 IF $GET(DUZ(2))
SET ^LAB(60,IFN1,8,0)="^60.11PA^"_DUZ(2)_"^1"
SET ^LAB(60,IFN1,8,DUZ(2),0)=DUZ(2)_"^"_$ORDER(^LRO(68,"B","BLOOD BANK",0))
+6 SET DA=IFN1
SET DIK="^LAB(60,"
DO IX^DIK
End DoDot:1
+7 SET $PIECE(^LAB(60,0),"^",3,4)=LAST
LOCK -^LAB(60)
+8 QUIT
DEL ;Delete components out of file 60 (for testing only)
+1 NEW IFN,X,DA,DIK
+2 SET IFN=0
FOR
SET IFN=$ORDER(^LAB(60,IFN))
if IFN<1
QUIT
IF $DATA(^(IFN,12))
IF +^(12)
SET DA=IFN
SET DIK="^LAB(60,"
DO ^DIK
WRITE "."
+3 QUIT
POS ;Post init for future blood bank patch, when/if ordering components
+1 NEW LRCHK
+2 SET LRCHK=$$NEWCP^XPDUTL("P1","P1^LR7OV3")
+3 QUIT
P1 ;Post init entry point
+1 DO BMES^XPDUTL("Now adding Blood Component Requests to Lab Test file...")
+2 DO EN
+3 DO MES^XPDUTL("Done adding Blood Component Requests")
+4 QUIT
