source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPPOW.m@ 1150

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

initial load of WorldVistAEHR

File size: 2.2 KB
Line 
1LRAPPOW ;AVAMC/REG/WTY - POW PATIENT LOOK-UP ;10/16/2001
2 ;;5.2;LAB SERVICE;**72,114,259**;Sep 27, 1994
3 ;
4 ;Reference to ^DIC(22 supported by IA #935
5 ;Reference to ^DPT supported by IA #918
6 ;
7 ;16-OCT-01;WTY;Unwrapped code and added device handling
8 ;
9 S:'$D(LRSF515) LRSF515=0
10 S:'$D(LR("Q")) LR("Q")=0
11 I $D(^DPT(DFN,.52)),$P(^(.52),U,5)="Y" D Q:LR("Q")
12 .S X=$P(^(.52),U,6)
13 .D FLG
14 I $D(^DPT(DFN,.322)) D
15 .S X=$P($G(^(.322)),"^",10)
16 .D:X="Y" R
17 Q
18FLG ;
19 D PAGE Q:LR("Q")
20 W !!?19,$C(7),"*** THIS PATIENT WAS A PRISONER OF WAR ***"
21 D PAGE Q:LR("Q")
22 W !!
23 I X S X=$S($D(^DIC(22,X,0)):$P(^(0),U,1),1:"") W ?24,"POW PERIOD: ",X
24 D PAGE Q:LR("Q")
25 W !!,"FORWARD A DUPLICATE SET OF SLIDES,BLOCKS AND REPRESENTATIVE "
26 W "WET TISSUE TO:"
27 D PAGE Q:LR("Q")
28 W !!,?3,"DIRECTOR,ARMED FORCES INSTITUTE OF PATHOLOGY"
29 D PAGE Q:LR("Q")
30 W !,?3,"ATTENTION: FORMER POW REGISTRY"
31 D PAGE Q:LR("Q")
32 W !,?3,"WASHINGTON, D.C. 20306",!,"<A POW label (VA Form 10-5558) may "
33 W "be attached to packaged specimens>"
34 D PAGE Q:LR("Q")
35 W !!,"MARK CASE CLEARLY AS:"
36 W " FORMER POW ",X
37 D PAGE Q:LR("Q")
38 W !,"NOTE IN APPROPRIATE FORM THAT MATERIAL HAS BEEN SENT TO THE AFIP"
39 I $D(LRSS),LRSS="AU" D NOTE
40 W !!
41 Q
42NOTE ;
43 D PAGE Q:LR("Q")
44 W !!,"Follow Guidelines for Performing Autopsy Examination on Former "
45 W "Prisoners of War (POW's) PROFESSIONAL SERVICES LETTER IL 11-82-17"
46 D PAGE Q:LR("Q")
47 W !,"Be sure to take appropriate samples of:"
48 D PAGE Q:LR("Q")
49 W !,"BRAIN, NERVE, TESTES, PROSTATE, URINARY BLADDER, and KIDNEY"
50 Q
51R ;
52 N LRTMP
53 D PAGE Q:LR("Q")
54 S LRTMP="***THIS PATIENT SERVED IN THE PERSIAN GULF WAR***"
55 W $C(7),!!,$$CJ^XLFSTR(LRTMP,IOM)
56 D PAGE Q:LR("Q")
57 W !!
58 D PAGE Q:LR("Q")
59 W !,$$CJ^XLFSTR("***************",IOM)
60 D PAGE Q:LR("Q")
61 S LRTMP="Send a set of DUPLICATE paraffin blocks/smears, "
62 S LRTMP=LRTMP_"H & E slides for "
63 W !!,$$CJ^XLFSTR(LRTMP,IOM)
64 D PAGE Q:LR("Q")
65 S LRTMP="Anatomic Path material and a copy of the Final Pathology "
66 S LRTMP=LRTMP_"Report to "
67 W !!,$$CJ^XLFSTR(LRTMP,IOM)
68 D PAGE Q:LR("Q")
69 W !!,$$CJ^XLFSTR("the AFIP using the AFIP Requisition form. ",IOM)
70 D PAGE Q:LR("Q")
71 W !!
72 D PAGE Q:LR("Q")
73 W !,$$CJ^XLFSTR("***************",IOM)
74 D PAGE Q:LR("Q")
75 W !
76 Q
77PAGE ;
78 Q:'LRSF515
79 D:$Y>(IOSL-13) F^LRAPF,^LRAPF
80 Q
Note: See TracBrowser for help on using the repository browser.