81 lines
2.2 KiB
Mathematica
81 lines
2.2 KiB
Mathematica
LRAPPOW ;AVAMC/REG/WTY - POW PATIENT LOOK-UP ;10/16/2001
|
|
;;5.2;LAB SERVICE;**72,114,259**;Sep 27, 1994
|
|
;
|
|
;Reference to ^DIC(22 supported by IA #935
|
|
;Reference to ^DPT supported by IA #918
|
|
;
|
|
;16-OCT-01;WTY;Unwrapped code and added device handling
|
|
;
|
|
S:'$D(LRSF515) LRSF515=0
|
|
S:'$D(LR("Q")) LR("Q")=0
|
|
I $D(^DPT(DFN,.52)),$P(^(.52),U,5)="Y" D Q:LR("Q")
|
|
.S X=$P(^(.52),U,6)
|
|
.D FLG
|
|
I $D(^DPT(DFN,.322)) D
|
|
.S X=$P($G(^(.322)),"^",10)
|
|
.D:X="Y" R
|
|
Q
|
|
FLG ;
|
|
D PAGE Q:LR("Q")
|
|
W !!?19,$C(7),"*** THIS PATIENT WAS A PRISONER OF WAR ***"
|
|
D PAGE Q:LR("Q")
|
|
W !!
|
|
I X S X=$S($D(^DIC(22,X,0)):$P(^(0),U,1),1:"") W ?24,"POW PERIOD: ",X
|
|
D PAGE Q:LR("Q")
|
|
W !!,"FORWARD A DUPLICATE SET OF SLIDES,BLOCKS AND REPRESENTATIVE "
|
|
W "WET TISSUE TO:"
|
|
D PAGE Q:LR("Q")
|
|
W !!,?3,"DIRECTOR,ARMED FORCES INSTITUTE OF PATHOLOGY"
|
|
D PAGE Q:LR("Q")
|
|
W !,?3,"ATTENTION: FORMER POW REGISTRY"
|
|
D PAGE Q:LR("Q")
|
|
W !,?3,"WASHINGTON, D.C. 20306",!,"<A POW label (VA Form 10-5558) may "
|
|
W "be attached to packaged specimens>"
|
|
D PAGE Q:LR("Q")
|
|
W !!,"MARK CASE CLEARLY AS:"
|
|
W " FORMER POW ",X
|
|
D PAGE Q:LR("Q")
|
|
W !,"NOTE IN APPROPRIATE FORM THAT MATERIAL HAS BEEN SENT TO THE AFIP"
|
|
I $D(LRSS),LRSS="AU" D NOTE
|
|
W !!
|
|
Q
|
|
NOTE ;
|
|
D PAGE Q:LR("Q")
|
|
W !!,"Follow Guidelines for Performing Autopsy Examination on Former "
|
|
W "Prisoners of War (POW's) PROFESSIONAL SERVICES LETTER IL 11-82-17"
|
|
D PAGE Q:LR("Q")
|
|
W !,"Be sure to take appropriate samples of:"
|
|
D PAGE Q:LR("Q")
|
|
W !,"BRAIN, NERVE, TESTES, PROSTATE, URINARY BLADDER, and KIDNEY"
|
|
Q
|
|
R ;
|
|
N LRTMP
|
|
D PAGE Q:LR("Q")
|
|
S LRTMP="***THIS PATIENT SERVED IN THE PERSIAN GULF WAR***"
|
|
W $C(7),!!,$$CJ^XLFSTR(LRTMP,IOM)
|
|
D PAGE Q:LR("Q")
|
|
W !!
|
|
D PAGE Q:LR("Q")
|
|
W !,$$CJ^XLFSTR("***************",IOM)
|
|
D PAGE Q:LR("Q")
|
|
S LRTMP="Send a set of DUPLICATE paraffin blocks/smears, "
|
|
S LRTMP=LRTMP_"H & E slides for "
|
|
W !!,$$CJ^XLFSTR(LRTMP,IOM)
|
|
D PAGE Q:LR("Q")
|
|
S LRTMP="Anatomic Path material and a copy of the Final Pathology "
|
|
S LRTMP=LRTMP_"Report to "
|
|
W !!,$$CJ^XLFSTR(LRTMP,IOM)
|
|
D PAGE Q:LR("Q")
|
|
W !!,$$CJ^XLFSTR("the AFIP using the AFIP Requisition form. ",IOM)
|
|
D PAGE Q:LR("Q")
|
|
W !!
|
|
D PAGE Q:LR("Q")
|
|
W !,$$CJ^XLFSTR("***************",IOM)
|
|
D PAGE Q:LR("Q")
|
|
W !
|
|
Q
|
|
PAGE ;
|
|
Q:'LRSF515
|
|
D:$Y>(IOSL-13) F^LRAPF,^LRAPF
|
|
Q
|