LR7OV3.m

LR7OV3 ; IHS/DIR/AAB - Update file 60 with Blood Component Request (66.9) ; [ 8/11/97 ]

 ;;5.2;LR;**1003**;JUN 01, 1998

 ;

 ;;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

LR7OV3    ; IHS/DIR/AAB - Update file 60 with Blood Component Request (66.9) ; [ 8/11/97 ]

 +1       ;;5.2;LR;**1003**;JUN 01, 1998

 +2       ;

 +3       ;;5.2;LAB SERVICE;**121**;Sep 27, 1994

 +4       ;

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