LRAPPOW ;DALOI/REG/WTY - POW PATIENT LOOK-UP ;01/29/13 16:51
;;5.2;LAB SERVICE;**72,114,259,427**;Sep 27, 1994;Build 33
;
;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,JOINT PATHOLOGY CENTER"
D PAGE Q:LR("Q")
W !,?3,"ATTENTION: FORMER POW REGISTRY"
D PAGE Q:LR("Q")
W !,?3,"606 STEPHEN SITTER AVENUE"
D PAGE Q:LR("Q")
W !,?3,"SILVER SPRING, MD 20910-1290",!,"<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 JPC"
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 JPC using the JPC 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPPOW 2415 printed Apr 09, 2024@21:16:28 Page 2
LRAPPOW ;DALOI/REG/WTY - POW PATIENT LOOK-UP ;01/29/13 16:51
+1 ;;5.2;LAB SERVICE;**72,114,259,427**;Sep 27, 1994;Build 33
+2 ;
+3 ;Reference to ^DIC(22 supported by IA #935
+4 ;Reference to ^DPT supported by IA #918
+5 ;
+6 ;16-OCT-01;WTY;Unwrapped code and added device handling
+7 ;
+8 if '$DATA(LRSF515)
SET LRSF515=0
+9 if '$DATA(LR("Q"))
SET LR("Q")=0
+10 IF $DATA(^DPT(DFN,.52))
IF $PIECE(^(.52),U,5)="Y"
Begin DoDot:1
+11 SET X=$PIECE(^(.52),U,6)
+12 DO FLG
End DoDot:1
if LR("Q")
QUIT
+13 IF $DATA(^DPT(DFN,.322))
Begin DoDot:1
+14 SET X=$PIECE($GET(^(.322)),"^",10)
+15 if X="Y"
DO R
End DoDot:1
+16 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,JOINT PATHOLOGY CENTER"
+11 DO PAGE
if LR("Q")
QUIT
+12 WRITE !,?3,"ATTENTION: FORMER POW REGISTRY"
+13 DO PAGE
if LR("Q")
QUIT
+14 WRITE !,?3,"606 STEPHEN SITTER AVENUE"
+15 DO PAGE
if LR("Q")
QUIT
+16 WRITE !,?3,"SILVER SPRING, MD 20910-1290",!,"<A POW label (VA Form 10-5558) may "
+17 WRITE "be attached to packaged specimens>"
+18 DO PAGE
if LR("Q")
QUIT
+19 WRITE !!,"MARK CASE CLEARLY AS:"
+20 WRITE " FORMER POW ",X
+21 DO PAGE
if LR("Q")
QUIT
+22 WRITE !,"NOTE IN APPROPRIATE FORM THAT MATERIAL HAS BEEN SENT TO THE JPC"
+23 IF $DATA(LRSS)
IF LRSS="AU"
DO NOTE
+24 WRITE !!
+25 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 JPC using the JPC 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
