- SRBLOOD ;B'HAM ISC/MM,SM - BLOOD PRODUCT VERIFICATION ;08/11/05
- ;;3.0; Surgery ;**74,85,101,148**;24 Jun 93
- ;
- ; References to ^LRD(65 supported by DBIA #2331-A
- ; References to ^LR( supported by DBIA #894 and 252-B
- ; References to ^LAB(66 supported by DBIA #210
- ; Reference to BAR^LRBLB supported by DBIA #2331-B
- ; Reference to ^LRBLBU supported by DBIA #2333
- ; Reference to VBECA1B supported by DBIA #4629
- ;
- S X="VBECA1B" X ^%ZOSF("TEST") I $T D ^SRBL Q ; check if VBECS installed
- SCAN D BAR^LRBLB ; scan UNIT ID before VBECS
- ;obtain the LRDFN from the patient's DFN
- S SRDFN=$P($G(^DPT($P(^SRF(SRTN,0),"^"),"LR")),"^")
- I SRDFN="" G SRNO
- K DIR S DIR(0)="F^1:50",DIR("A")="Enter Blood Product Identifier",DIR("?")="Enter or scan the Blood Product Unit Id" D ^DIR G END:$D(DIRUT)
- W ! D ^LRBLBU S SRUNIT=$G(X) I SRUNIT="" G SRNO
- ;if patient is not on the "AP" 'DO NOT Give' (no display)
- I '$O(^LRD(65,"AP",SRDFN,0)) G SRNO
- I '$O(^LRD(65,"B",SRUNIT,0)),('$O(^LRD(65,"C",SRUNIT,0))) G SRNO
- S (SRIEN,SRICNT,SROCNT,SROK)=0 F S SRIEN=$O(^LRD(65,"B",SRUNIT,SRIEN)) Q:'SRIEN S SROCNT=SROCNT+1,SRO(SROCNT)=SRIEN
- S (SRIEN)=0 F S SRIEN=$O(^LRD(65,"C",SRUNIT,SRIEN)) Q:'SRIEN S SROCNT=SROCNT+1,SRO(SROCNT)=SRIEN
- S (SRLRD,SRICNT)=0 F SRZ=1:1:SROCNT D
- .;S SRIEN=SRO(SRZ) I '$O(^LRD(65,SRIEN,2,0)) S SRICNT=SRICNT+1,SRB(SRICNT)=SRIEN_"^"_0 Q ;checks for "No date/time unit assigned"
- .S SRIEN=SRO(SRZ) I '$O(^LRD(65,SRIEN,2,0)) Q
- .S SRLRD=0 F S SRLRD=$O(^LRD(65,SRIEN,2,SRLRD)) Q:'SRLRD D
- ..Q:'$D(^LRD(65,"AP",SRLRD,SRIEN))
- ..S SRICNT=SRICNT+1,SRB(SRICNT)=SRIEN_"^"_SRLRD
- ..I SRLRD=SRDFN S SROK=1
- I '$D(SROK) G SRNO
- ;look through the list of patients assigned to the unit id for selected patient
- S (SRC2,SRFLAG)=0 F SRZ=1:1:SRICNT D
- .I SRC2=SROCNT Q
- .I SRZ=SRICNT,(SRFLAG=0) S SRD(SRC2+1)=SRB(SRZ) Q
- .I SRZ=SRICNT,(SRFLAG=1) Q
- .I $P(SRB(SRZ),"^",2)=SRDFN S SRFLAG=1,SRC2=SRC2+1,SRD(SRC2)=SRB(SRZ)
- .I $P(SRB(SRZ),"^")=$P(SRB(SRZ+1),"^") Q
- .I SRFLAG=1 S SRFLAG=0 Q
- .I SRFLAG=0 S SRC2=SRC2+1,SRD(SRC2)=SRB(SRZ)
- ;
- ;create the display
- I '$D(SRD) G SRNO
- ;if selected patient is assigned to each unit id, no display necessary
- S SRI="",(SRDS,SRDSP,SRFLAG,SRNODT,SREXP)=0 F S SRI=$O(SRD(SRI)) Q:SRI="" D
- .I $P(SRD(SRI),"^",2)'=SRDFN S SRDSP=1
- .;I $D(^LRD(65,"AP",$P(SRD(SRI),"^",2),$P(SRD(SRI),"^")))
- .;E S SRDS=1,SRD(SRI)=SRD(SRI)_"^"_" **NO DATE/TIME UNIT ASSIGNED **",SRNODT=1
- .S DFN=$P(SRD(SRI),"^",2)
- .I DFN'=0 S DFN=$P(^LR(DFN,0),"^",3) D DEM^VADPT S $P(SRD(SRI),"^",6)=VADM(1)_" "_VA("PID")
- .I DFN=0 S $P(SRD(SRI),"^",6)="Not Assigned"
- .S SRIEN=$P(SRD(SRI),"^"),SRUNIT=$P(SRD(SRI),"^"),(Y,Z)=$P($G(^LRD(65,SRIEN,0)),"^",6) I Y'="" X ^DD("DD") S $P(SRD(SRI),"^",5)=Y I Z<DT S $P(SRD(SRI),"^",4)="Today's date exceeds the blood product expiration date.",SREXP=1
- I SRDSP=0,(SRDS=0) I SRNODT=0,(SREXP=0) G SRYES
- I SROCNT=1,$D(SROK) S Y=1 G CHECKS
- S SRI="",SRZ=0 F S SRI=$O(SRD(SRI)) Q:SRI="" D
- .S SRZ=SRZ+1,SRIEN=$P(SRD(SRI),"^"),SRUNIT=$P(^LRD(65,SRIEN,0),"^")
- .W !!," ",SRI_")"," Unit ID: ",SRUNIT,?45,$P(^LAB(66,$P(^LRD(65,SRIEN,0),"^",4),0),"^")
- .W !,?4,"Patient: ",$P(SRD(SRI),"^",6),?45,"Expiration Date: ",?40,$P(SRD(SRI),"^",5)
- .I $P(SRD(SRI),"^",3)'="" W !,$P(SRD(SRI),"^",3)
- W ! K DIR S DIR(0)="NO^1:"_SRZ,DIR("A")="Select the blood product matching the unit label" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y G END
- CHECKS I $P(SRD(Y),"^",2)'=SRDFN G SRNO
- I $P(SRD(Y),"^",4)'="" S SRFLAG=1 W !!," **WARNING**",!!,$P(SRD(Y),"^",4),!
- ;I $P(SRD(Y),"^",3)["**NO DATE" S SRFLAG=1 W !!," There is no 'DATE/TIME Unit Assigned' for this entry."
- I SRFLAG=1 G ASK
- SRYES W !!!,?25,"No Discrepancies Found",!!! K DIR S DIR(0)="FOA",DIR("A")="Press RETURN to continue" D ^DIR G END
- SRNO W !!,?30,"**WARNING**",!!
- W ?5,"There is no record that this unit has been assigned to this patient."
- W !!,?8," Please recheck the patient and blood product IDs.",!!
- ASK K DIR S DIR(0)="Y",DIR("A")="Do you want to scan another product (Y/N)",DIR("B")="YES" D ^DIR
- END K SRC2,SRDFN,SRFLAG,SRICNT,SROCNT,SRZ,SRDSP,SRBLOOD,SRB,SRO,SRD,SRDS,SROK,SRIEN,SRLRD,SRUNIT,SRNODT,SREXP,SRI
- I Y=1 G SCAN
- Q
- AUDIT S L=0,DIC=19.081,FLDS="[XUOPTLOGP]",BY="[SR BLOOD PRODUCT VERIFICATION]" D EN1^DIP
- Q
- PAGE I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR
- W @IOF
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRBLOOD 4383 printed Feb 19, 2025@00:05:33 Page 2
- SRBLOOD ;B'HAM ISC/MM,SM - BLOOD PRODUCT VERIFICATION ;08/11/05
- +1 ;;3.0; Surgery ;**74,85,101,148**;24 Jun 93
- +2 ;
- +3 ; References to ^LRD(65 supported by DBIA #2331-A
- +4 ; References to ^LR( supported by DBIA #894 and 252-B
- +5 ; References to ^LAB(66 supported by DBIA #210
- +6 ; Reference to BAR^LRBLB supported by DBIA #2331-B
- +7 ; Reference to ^LRBLBU supported by DBIA #2333
- +8 ; Reference to VBECA1B supported by DBIA #4629
- +9 ;
- +10 ; check if VBECS installed
- SET X="VBECA1B"
- XECUTE ^%ZOSF("TEST")
- IF $TEST
- DO ^SRBL
- QUIT
- SCAN ; scan UNIT ID before VBECS
- DO BAR^LRBLB
- +1 ;obtain the LRDFN from the patient's DFN
- +2 SET SRDFN=$PIECE($GET(^DPT($PIECE(^SRF(SRTN,0),"^"),"LR")),"^")
- +3 IF SRDFN=""
- GOTO SRNO
- +4 KILL DIR
- SET DIR(0)="F^1:50"
- SET DIR("A")="Enter Blood Product Identifier"
- SET DIR("?")="Enter or scan the Blood Product Unit Id"
- DO ^DIR
- if $DATA(DIRUT)
- GOTO END
- +5 WRITE !
- DO ^LRBLBU
- SET SRUNIT=$GET(X)
- IF SRUNIT=""
- GOTO SRNO
- +6 ;if patient is not on the "AP" 'DO NOT Give' (no display)
- +7 IF '$ORDER(^LRD(65,"AP",SRDFN,0))
- GOTO SRNO
- +8 IF '$ORDER(^LRD(65,"B",SRUNIT,0))
- IF ('$ORDER(^LRD(65,"C",SRUNIT,0)))
- GOTO SRNO
- +9 SET (SRIEN,SRICNT,SROCNT,SROK)=0
- FOR
- SET SRIEN=$ORDER(^LRD(65,"B",SRUNIT,SRIEN))
- if 'SRIEN
- QUIT
- SET SROCNT=SROCNT+1
- SET SRO(SROCNT)=SRIEN
- +10 SET (SRIEN)=0
- FOR
- SET SRIEN=$ORDER(^LRD(65,"C",SRUNIT,SRIEN))
- if 'SRIEN
- QUIT
- SET SROCNT=SROCNT+1
- SET SRO(SROCNT)=SRIEN
- +11 SET (SRLRD,SRICNT)=0
- FOR SRZ=1:1:SROCNT
- Begin DoDot:1
- +12 ;S SRIEN=SRO(SRZ) I '$O(^LRD(65,SRIEN,2,0)) S SRICNT=SRICNT+1,SRB(SRICNT)=SRIEN_"^"_0 Q ;checks for "No date/time unit assigned"
- +13 SET SRIEN=SRO(SRZ)
- IF '$ORDER(^LRD(65,SRIEN,2,0))
- QUIT
- +14 SET SRLRD=0
- FOR
- SET SRLRD=$ORDER(^LRD(65,SRIEN,2,SRLRD))
- if 'SRLRD
- QUIT
- Begin DoDot:2
- +15 if '$DATA(^LRD(65,"AP",SRLRD,SRIEN))
- QUIT
- +16 SET SRICNT=SRICNT+1
- SET SRB(SRICNT)=SRIEN_"^"_SRLRD
- +17 IF SRLRD=SRDFN
- SET SROK=1
- End DoDot:2
- End DoDot:1
- +18 IF '$DATA(SROK)
- GOTO SRNO
- +19 ;look through the list of patients assigned to the unit id for selected patient
- +20 SET (SRC2,SRFLAG)=0
- FOR SRZ=1:1:SRICNT
- Begin DoDot:1
- +21 IF SRC2=SROCNT
- QUIT
- +22 IF SRZ=SRICNT
- IF (SRFLAG=0)
- SET SRD(SRC2+1)=SRB(SRZ)
- QUIT
- +23 IF SRZ=SRICNT
- IF (SRFLAG=1)
- QUIT
- +24 IF $PIECE(SRB(SRZ),"^",2)=SRDFN
- SET SRFLAG=1
- SET SRC2=SRC2+1
- SET SRD(SRC2)=SRB(SRZ)
- +25 IF $PIECE(SRB(SRZ),"^")=$PIECE(SRB(SRZ+1),"^")
- QUIT
- +26 IF SRFLAG=1
- SET SRFLAG=0
- QUIT
- +27 IF SRFLAG=0
- SET SRC2=SRC2+1
- SET SRD(SRC2)=SRB(SRZ)
- End DoDot:1
- +28 ;
- +29 ;create the display
- +30 IF '$DATA(SRD)
- GOTO SRNO
- +31 ;if selected patient is assigned to each unit id, no display necessary
- +32 SET SRI=""
- SET (SRDS,SRDSP,SRFLAG,SRNODT,SREXP)=0
- FOR
- SET SRI=$ORDER(SRD(SRI))
- if SRI=""
- QUIT
- Begin DoDot:1
- +33 IF $PIECE(SRD(SRI),"^",2)'=SRDFN
- SET SRDSP=1
- +34 ;I $D(^LRD(65,"AP",$P(SRD(SRI),"^",2),$P(SRD(SRI),"^")))
- +35 ;E S SRDS=1,SRD(SRI)=SRD(SRI)_"^"_" **NO DATE/TIME UNIT ASSIGNED **",SRNODT=1
- +36 SET DFN=$PIECE(SRD(SRI),"^",2)
- +37 IF DFN'=0
- SET DFN=$PIECE(^LR(DFN,0),"^",3)
- DO DEM^VADPT
- SET $PIECE(SRD(SRI),"^",6)=VADM(1)_" "_VA("PID")
- +38 IF DFN=0
- SET $PIECE(SRD(SRI),"^",6)="Not Assigned"
- +39 SET SRIEN=$PIECE(SRD(SRI),"^")
- SET SRUNIT=$PIECE(SRD(SRI),"^")
- SET (Y,Z)=$PIECE($GET(^LRD(65,SRIEN,0)),"^",6)
- IF Y'=""
- XECUTE ^DD("DD")
- SET $PIECE(SRD(SRI),"^",5)=Y
- IF Z<DT
- SET $PIECE(SRD(SRI),"^",4)="Today's date exceeds the blood product expiration date."
- SET SREXP=1
- End DoDot:1
- +40 IF SRDSP=0
- IF (SRDS=0)
- IF SRNODT=0
- IF (SREXP=0)
- GOTO SRYES
- +41 IF SROCNT=1
- IF $DATA(SROK)
- SET Y=1
- GOTO CHECKS
- +42 SET SRI=""
- SET SRZ=0
- FOR
- SET SRI=$ORDER(SRD(SRI))
- if SRI=""
- QUIT
- Begin DoDot:1
- +43 SET SRZ=SRZ+1
- SET SRIEN=$PIECE(SRD(SRI),"^")
- SET SRUNIT=$PIECE(^LRD(65,SRIEN,0),"^")
- +44 WRITE !!," ",SRI_")"," Unit ID: ",SRUNIT,?45,$PIECE(^LAB(66,$PIECE(^LRD(65,SRIEN,0),"^",4),0),"^")
- +45 WRITE !,?4,"Patient: ",$PIECE(SRD(SRI),"^",6),?45,"Expiration Date: ",?40,$PIECE(SRD(SRI),"^",5)
- +46 IF $PIECE(SRD(SRI),"^",3)'=""
- WRITE !,$PIECE(SRD(SRI),"^",3)
- End DoDot:1
- +47 WRITE !
- KILL DIR
- SET DIR(0)="NO^1:"_SRZ
- SET DIR("A")="Select the blood product matching the unit label"
- DO ^DIR
- KILL DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)!'Y
- GOTO END
- CHECKS IF $PIECE(SRD(Y),"^",2)'=SRDFN
- GOTO SRNO
- +1 IF $PIECE(SRD(Y),"^",4)'=""
- SET SRFLAG=1
- WRITE !!," **WARNING**",!!,$PIECE(SRD(Y),"^",4),!
- +2 ;I $P(SRD(Y),"^",3)["**NO DATE" S SRFLAG=1 W !!," There is no 'DATE/TIME Unit Assigned' for this entry."
- +3 IF SRFLAG=1
- GOTO ASK
- SRYES WRITE !!!,?25,"No Discrepancies Found",!!!
- KILL DIR
- SET DIR(0)="FOA"
- SET DIR("A")="Press RETURN to continue"
- DO ^DIR
- GOTO END
- SRNO WRITE !!,?30,"**WARNING**",!!
- +1 WRITE ?5,"There is no record that this unit has been assigned to this patient."
- +2 WRITE !!,?8," Please recheck the patient and blood product IDs.",!!
- ASK KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Do you want to scan another product (Y/N)"
- SET DIR("B")="YES"
- DO ^DIR
- END KILL SRC2,SRDFN,SRFLAG,SRICNT,SROCNT,SRZ,SRDSP,SRBLOOD,SRB,SRO,SRD,SRDS,SROK,SRIEN,SRLRD,SRUNIT,SRNODT,SREXP,SRI
- +1 IF Y=1
- GOTO SCAN
- +2 QUIT
- AUDIT SET L=0
- SET DIC=19.081
- SET FLDS="[XUOPTLOGP]"
- SET BY="[SR BLOOD PRODUCT VERIFICATION]"
- DO EN1^DIP
- +1 QUIT
- PAGE IF $EXTRACT(IOST,1,2)="C-"
- SET DIR(0)="E"
- DO ^DIR
- +1 WRITE @IOF
- +2 QUIT