LRAPPOW ;AVAMC/REG/WTY - POW PATIENT LOOK-UP ;10/16/2001
;;5.2;LAB SERVICE;**1030**;NOV 01, 1997
;;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
LRAPPOW ;AVAMC/REG/WTY - POW PATIENT LOOK-UP ;10/16/2001
+1 ;;5.2;LAB SERVICE;**1030**;NOV 01, 1997
+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 IF '$DATA(LRSF515)
SET LRSF515=0
+10 IF '$DATA(LR("Q"))
SET LR("Q")=0
+11 IF $DATA(^DPT(DFN,.52))
IF $PIECE(^(.52),U,5)="Y"
Begin DoDot:1
+12 SET X=$PIECE(^(.52),U,6)
+13 DO FLG
End DoDot:1
IF LR("Q")
QUIT
+14 IF $DATA(^DPT(DFN,.322))
Begin DoDot:1
+15 SET X=$PIECE($GET(^(.322)),"^",10)
+16 IF X="Y"
DO R
End DoDot:1
+17 QUIT
FLG ;
+1 DO PAGE
IF LR("Q")
QUIT
+2 WRITE !!?19,$CHAR(7),"*** THIS PATIENT WAS A PRISONER OF WAR ***"
+3 DO PAGE
IF LR("Q")
QUIT
+4 WRITE !!
+5 IF X
SET X=$SELECT($DATA(^DIC(22,X,0)):$PIECE(^(0),U,1),1:"")
WRITE ?24,"POW PERIOD: ",X
+6 DO PAGE
IF LR("Q")
QUIT
+7 WRITE !!,"FORWARD A DUPLICATE SET OF SLIDES,BLOCKS AND REPRESENTATIVE "
+8 WRITE "WET TISSUE TO:"
+9 DO PAGE
IF LR("Q")
QUIT
+10 WRITE !!,?3,"DIRECTOR,ARMED FORCES INSTITUTE OF PATHOLOGY"
+11 DO PAGE
IF LR("Q")
QUIT
+12 WRITE !,?3,"ATTENTION: FORMER POW REGISTRY"
+13 DO PAGE
IF LR("Q")
QUIT
+14 WRITE !,?3,"WASHINGTON, D.C. 20306",!,"<A POW label (VA Form 10-5558) may "
+15 WRITE "be attached to packaged specimens>"
+16 DO PAGE
IF LR("Q")
QUIT
+17 WRITE !!,"MARK CASE CLEARLY AS:"
+18 WRITE " FORMER POW ",X
+19 DO PAGE
IF LR("Q")
QUIT
+20 WRITE !,"NOTE IN APPROPRIATE FORM THAT MATERIAL HAS BEEN SENT TO THE AFIP"
+21 IF $DATA(LRSS)
IF LRSS="AU"
DO NOTE
+22 WRITE !!
+23 QUIT
NOTE ;
+1 DO PAGE
IF LR("Q")
QUIT
+2 WRITE !!,"Follow Guidelines for Performing Autopsy Examination on Former "
+3 WRITE "Prisoners of War (POW's) PROFESSIONAL SERVICES LETTER IL 11-82-17"
+4 DO PAGE
IF LR("Q")
QUIT
+5 WRITE !,"Be sure to take appropriate samples of:"
+6 DO PAGE
IF LR("Q")
QUIT
+7 WRITE !,"BRAIN, NERVE, TESTES, PROSTATE, URINARY BLADDER, and KIDNEY"
+8 QUIT
R ;
+1 NEW LRTMP
+2 DO PAGE
IF LR("Q")
QUIT
+3 SET LRTMP="***THIS PATIENT SERVED IN THE PERSIAN GULF WAR***"
+4 WRITE $CHAR(7),!!,$$CJ^XLFSTR(LRTMP,IOM)
+5 DO PAGE
IF LR("Q")
QUIT
+6 WRITE !!
+7 DO PAGE
IF LR("Q")
QUIT
+8 WRITE !,$$CJ^XLFSTR("***************",IOM)
+9 DO PAGE
IF LR("Q")
QUIT
+10 SET LRTMP="Send a set of DUPLICATE paraffin blocks/smears, "
+11 SET LRTMP=LRTMP_"H & E slides for "
+12 WRITE !!,$$CJ^XLFSTR(LRTMP,IOM)
+13 DO PAGE
IF LR("Q")
QUIT
+14 SET LRTMP="Anatomic Path material and a copy of the Final Pathology "
+15 SET LRTMP=LRTMP_"Report to "
+16 WRITE !!,$$CJ^XLFSTR(LRTMP,IOM)
+17 DO PAGE
IF LR("Q")
QUIT
+18 WRITE !!,$$CJ^XLFSTR("the AFIP using the AFIP Requisition form. ",IOM)
+19 DO PAGE
IF LR("Q")
QUIT
+20 WRITE !!
+21 DO PAGE
IF LR("Q")
QUIT
+22 WRITE !,$$CJ^XLFSTR("***************",IOM)
+23 DO PAGE
IF LR("Q")
QUIT
+24 WRITE !
+25 QUIT
PAGE ;
+1 IF 'LRSF515
QUIT
+2 IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
+3 QUIT
