source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLDPA1.m@ 1521

Last change on this file since 1521 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1LRBLDPA1 ;AVAMC/REG/CYM - BLOOD DONOR PRINT ;7/5/96 20:57 ;
2 ;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 N LRDOB,NAME S (X,LRX)=^LRE(LR,0),PNM=$P(X,U),SEX=$P(X,U,2),LRABO=$P(X,U,5),LRRH=$P(X,U,6),SSN=$P(X,U,13),Y=$P(X,U,3) D D^LRU S LRDOB=Y,LRF=65.5,Z=.02,X=SEX D S S SEX=Y
5 D H S LR("F")=1 S X=$P(LRX,U,13) W:X]"" !,"SSN: ",X S X=$P(X,U,14) W:X]"" !,"MILITARY RANK: ",X
6 K ^TMP($J) S LRE=0 F LRJ=0:1 S LRE=$O(^LRE(LR,9,LRE)) Q:'LRE!(LR("Q")) S LRA=^(LRE,0) D:$Y>(IOSL-6) H Q:LR("Q") S X=LRA D ^DIWP
7 Q:LR("Q") D:LRJ ^DIWW Q:LR("Q") D:$Y>(IOSL-6) H Q:LR("Q")
8 S X=$P(LRX,U,10),Z=.1 D S W ! W:X]"" "PERMANENT DEFERRAL: ",Y S X=+$P(LRX,U,12) D V W:X]"" ?29,"DEFERRAL ENTER/EDIT: ",X
9 S Y=$P(LRX,U,16) I Y D D^LRU W !,"PERMANENT DEFERRAL DATE CHANGE: ",Y
10 K ^TMP($J) S LRE=0 F LRJ=0:1 S LRE=$O(^LRE(LR,99,LRE)) Q:'LRE!(LR("Q")) S LRA=^(LRE,0) D:$Y>(IOSL-6) H Q:LR("Q") W:LRJ=0 !,"PERMANENT DEFERRAL REASON:" S X=LRA D ^DIWP
11 Q:LR("Q") D:LRJ ^DIWW Q:LR("Q") D:$Y>(IOSL-6) H Q:LR("Q") D A^LRBLDPA2 Q:LR("Q") D:$Y>(IOSL-6) H Q:LR("Q")
12 Q:LR("Q") K F S LRF=65.53,E=1,(F(1),G)="" F A=0:0 S A=$O(^LRE(LR,4,A)),Z=.01 Q:'A S X=$P(^LRE(LR,4,A,0),U) D S S F(E)=F(E)_Y_", ",G=G+1 I $L(F(E))>60 S F(E)=$P(F(E),", ",1,G-1),E=E+1,F(E)=Y_", ",G=""
13 I F(1)]"" W !!,"SCHEDULING/RECALL: " S X=F(1) D C^LRBLDPA2 I $D(F(2)) W !?19 S X=F(2) D C^LRBLDPA2
14 D:$Y>(IOSL-6) H Q:LR("Q") K F S E=1,(F(1))="" F A=0:0 S A=$O(^LRE(LR,2,A)) Q:'A S X=A D G S F(E)=X(3),E=E+1
15 I F(1)]"" W !,"GROUP AFFILIATION: " F E=0:0 S E=$O(F(E)) Q:'E!(LR("Q")) D:$Y>(IOSL-6) H1 Q:LR("Q") W:E>1 ! W ?19,F(E)
16 Q:LR("Q") D:$Y>(IOSL-6) H Q:LR("Q") S LRF=65.5,X=$P(LRX,U,4),Z=.04 D S W !!?3,"APHERESIS: ",Y,?28,"CUMULATIVE DONATIONS: ",$P(LRX,U,7)
17 W !,"TOTAL AWARDS: ",$P(LRX,U,8),?34,"GIVE NEW AWARD: " S X=$S($D(^LRE(LR,3)):$P(^(3),U),1:"") I X]"" S Z=.085 D S W Y
18 S X=+$P(LRX,U,9) D V W !?2,"DEMOG EDIT: ",X S Y=$P(LRX,U,11) D D^LRU W ?45,"DATE REG/EDITED: ",Y
19 S X=$S($D(^LRE(LR,1)):^(1),1:"") W !!?3,"ADDRESS: ",$P(X,U)," ",$P(X,U,2) S Y=$P(X,U,3) W:Y]"" !?12,Y W !?12,$P(X,U,4),", " S Y=+$P(X,U,5) W $S($D(^DIC(5,Y,0)):$P(^(0),U),1:"")," ",$P(X,U,6)
20 D:$Y>(IOSL-6) H Q:LR("Q") W !,"HOME PHONE: ",$P(X,U,7),?38,"WORK PHONE: ",$P(X,U,8)
21 I $D(LRI) S A=LRI,LRF=65.54,LRX=^LRE(LR,5,LRI,0) D W D:LRN=1 ^LRBLDPAW Q
22 S A=0 F B=1:1 S A=$O(^LRE(LR,5,A)) Q:'A!(LR("Q")) S LRF=65.54,LRX=^(A,0) D:$Y>(IOSL-6) H Q:LR("Q") D W Q:LR("Q")
23 Q
24W S Y=+LRX D D^LRU S LRY=Y D FIELD^DID(65.54,.01,"","LABEL","NAME") S NAME=NAME("LABEL") W !!,NAME,": ",Y
25 S Z=1,X=$P(LRX,U,2) D S W ?40,"DONATION CODE: ",Y S X=+$P(LRX,U,6) D G W !,"COLLECTION SITE: ",X S X=+$P(LRX,U,7) D G W ?40,"DONATION GROUP: ",$E(X,1,24)
26 S Y=$P(LRX,U,13) D D^LRU W !,"ARRIVAL/APPT TIME: ",Y,?40,"ENTER/EDIT: " S X=+$P(LRX,U,8) D V W X D M Q:LR("Q")
27 I $P(LRX,U,14) S X=$P(LRX,U,14),Z=.14 D S D FIELD^DID(65.54,.14,"","LABEL","NAME") S NAME=NAME("LABEL") W !,NAME,": ",Y
28 D M Q:LR("Q") S X=$P(LRX,U,11),Z=1.1 D S,FIELD^DID(65.54,1.1,"","LABEL","NAME") S NAME=NAME("LABEL") W !,NAME,": ",Y
29 S X=$P(LRX,U,12) I X D P^LRBLDPA2 D FIELD^DID(65.54,1.2,"","LABEL","NAME") S NAME=NAME("LABEL") W !,NAME,": ",$P(X,U)," ",$P(X,U,9)
30 S X=+$P(LRX,U,3) D G W ?40,"DONOR REACTION: ",X
31 S C=0 F E=1:1 S C=$O(^LRE(LR,5,A,1,C)) Q:'C!(LR("Q")) S LRA=^(C,0) D M Q:LR("Q") W:E=1 !,"DEFERRAL REASON:" S X=+LRA D G W:X]"" !?3,X(3)
32 D M Q:LR("Q") W:$P(LRX,U,4)]"" !,"UNIT ID: ",$P(LRX,U,4) S LRZ=$S($D(^LRE(LR,5,A,2)):^(2),1:"") Q:LRZ="" W ?40,"PRIMARY BAG: " S X=$P(LRZ,U,1),Z=4.1 D S W Y
33 S X=$P(LRZ,U,9),Z=4.11 D S W !,"ANTICOAGULANT: ",Y,?40,"BAG LOT #: ",$P(LRZ,U,10)
34 D ^LRBLDPA2 Q
35G S X=$S($D(^LAB(65.4,X,0)):^(0),1:""),X(3)=$P(X,U,3),X=$P(X,U) Q
36V S X=$S($D(^VA(200,X,0)):$P(^(0),U),1:"") Q
37M S LRM=0 I $Y>(IOSL-6) D H S LRM=1
38 Q:LR("Q") W:LRM !,"DONATION OR DEFERRAL DATE: ",LRY Q
39H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
40 D F^LRU W !," BLOOD DONOR: ",PNM,?45,"DOB: ",LRDOB,!?9,"SEX: ",SEX,?42,"ABO/RH: ",LRABO," ",LRRH,!
41 Q
42H1 D H Q:LR("Q") W !!,"GROUP AFFILIATION:" Q
43 ;
44S I X=":" S (X,Y)="" Q
45 S Y=$$EXTERNAL^DILFD(LRF,Z,"",X) Q
Note: See TracBrowser for help on using the repository browser.