LRAPDPT ;AVAMC/REG/CYM - POW PTS ;2/10/98 22:15 ;
;;5.2;LAB SERVICE;**72,114,201**;Sep 27, 1994
D ^LRAP G:'$D(Y) END D XR^LRU S LRC=0 W !!?25,LRO(68)," SEARCH FOR",!?28,"PRISONER OF WAR VETERANS",!!
DATE D B^LRU G:Y<0 END S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
DEV S ZTRTN="QUE^LRAPDPT" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) S LRB=9999999.98-LRLDT,LRE=9999999.98-LRSDT D L^LRU,S^LRU,H S LR("F")=1
F A=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D LRDFN
D W W:IOST'?1"C".E @IOF K ^TMP($J) D END^LRUTL,END Q
LRDFN F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN D CK
Q
CK Q:$P(^LR(LRDFN,0),"^",2)'=2 S DFN=$P(^(0),"^",3),S(4)=""
I 'LRC Q:$P($G(^DPT(DFN,.52)),"^",5)'="Y" S X=$P(^(.52),"^",6) S:X X=$S($D(^DIC(22,X,0)):$P(^(0),"^"),1:"") S S(4)=S(4)_"POW " S:$L(X) S(4)=S(4)_" PERIOD "_X
I LRC=1 S X=$P($G(^DPT(DFN,.322)),"^",10) Q:X'="Y"
S X=^DPT(DFN,0),LRP=$P(X,"^"),LRDPF=2,SSN=$P(X,"^",9),Y=$P(X,"^",3) D D^LRU,SSN^LRU S ^TMP($J,LRP,SSN)=Y_"^"_S(4)_"^"_LRDFN
Q
;
EN ; Persian gulf registry
D ^LRAP G:'$D(Y) END D XR^LRU S LRC=1 W !!?25,LRO(68)," SEARCH FOR",!?28,"PERSIAN GULF VETERANS",!! G DATE
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,LRO(68)," (",LRABV,")",?40,$S('LRC:" POW VETERANS",1:" *PERSIAN GULF SERVICE* "),!,"From: ",LRSTR," to ",LRLST
W !,"Patient",?40,"DOB",?60,"ID",!,LR("%") Q
H1 D H Q:LR("Q") W !,LRN,?40,$P(P,"^"),?60,I,!?5,"Continued from page ",LRQ-1 Q
W S LRN=0 F A=0:0 S LRN=$O(^TMP($J,LRN)) Q:LRN=""!(LR("Q")) S I=0 D A
Q
A F B=0:0 S I=$O(^TMP($J,LRN,I)) Q:I=""!(LR("Q")) S P=^(I),LRDFN=+$P(P,"^",3) D:$Y>(IOSL-6) H Q:LR("Q") W !,LRN,?40,$P(P,"^"),?60,I,!?5,$P(P,"^",2) D @$S(LRSS="AU":"AU",1:"AP") W !,LR("%")
Q
AP F LRI=LRB:0 S LRI=$O(^LR(LRDFN,LRSS,LRI)) Q:'LRI!(LRI>LRE)!(LR("Q")) S LRX=^(LRI,0) I $P($P(LRX,U,6)," ")=LRABV D:$Y>(IOSL-6) H1 Q:LR("Q") W !,"Specimen date: ",$$FMTE^XLFDT(+LRX),?40,"Accession number: ",$P(LRX,"^",6)
Q
AU S X=$G(^LR(LRDFN,"AU")) I $P($P(X,U,6)," ")=LRABV W !,"Autopsy date: ",$$FMTE^XLFDT(+X),?30,"Autopsy number: ",$P(X,"^",6)
Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPDPT 2112 printed Apr 09, 2024@21:24:04 Page 2
LRAPDPT ;AVAMC/REG/CYM - POW PTS ;2/10/98 22:15 ;
+1 ;;5.2;LAB SERVICE;**72,114,201**;Sep 27, 1994
+2 DO ^LRAP
if '$DATA(Y)
GOTO END
DO XR^LRU
SET LRC=0
WRITE !!?25,LRO(68)," SEARCH FOR",!?28,"PRISONER OF WAR VETERANS",!!
DATE DO B^LRU
if Y<0
GOTO END
SET LRSDT=LRSDT-.01
SET LRLDT=LRLDT+.99
DEV SET ZTRTN="QUE^LRAPDPT"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
SET LRB=9999999.98-LRLDT
SET LRE=9999999.98-LRSDT
DO L^LRU
DO S^LRU
DO H
SET LR("F")=1
+1 FOR A=0:0
SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
if 'LRSDT!(LRSDT>LRLDT)
QUIT
DO LRDFN
+2 DO W
if IOST'?1"C".E
WRITE @IOF
KILL ^TMP($JOB)
DO END^LRUTL
DO END
QUIT
LRDFN FOR LRDFN=0:0
SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))
if 'LRDFN
QUIT
DO CK
+1 QUIT
CK if $PIECE(^LR(LRDFN,0),"^",2)'=2
QUIT
SET DFN=$PIECE(^(0),"^",3)
SET S(4)=""
+1 IF 'LRC
if $PIECE($GET(^DPT(DFN,.52)),"^",5)'="Y"
QUIT
SET X=$PIECE(^(.52),"^",6)
if X
SET X=$SELECT($DATA(^DIC(22,X,0)):$PIECE(^(0),"^"),1:"")
SET S(4)=S(4)_"POW "
if $LENGTH(X)
SET S(4)=S(4)_" PERIOD "_X
+2 IF LRC=1
SET X=$PIECE($GET(^DPT(DFN,.322)),"^",10)
if X'="Y"
QUIT
+3 SET X=^DPT(DFN,0)
SET LRP=$PIECE(X,"^")
SET LRDPF=2
SET SSN=$PIECE(X,"^",9)
SET Y=$PIECE(X,"^",3)
DO D^LRU
DO SSN^LRU
SET ^TMP($JOB,LRP,SSN)=Y_"^"_S(4)_"^"_LRDFN
+4 QUIT
+5 ;
EN ; Persian gulf registry
+1 DO ^LRAP
if '$DATA(Y)
GOTO END
DO XR^LRU
SET LRC=1
WRITE !!?25,LRO(68)," SEARCH FOR",!?28,"PERSIAN GULF VETERANS",!!
GOTO DATE
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,LRO(68)," (",LRABV,")",?40,$SELECT('LRC:" POW VETERANS",1:" *PERSIAN GULF SERVICE* "),!,"From: ",LRSTR," to ",LRLST
+2 WRITE !,"Patient",?40,"DOB",?60,"ID",!,LR("%")
QUIT
H1 DO H
if LR("Q")
QUIT
WRITE !,LRN,?40,$PIECE(P,"^"),?60,I,!?5,"Continued from page ",LRQ-1
QUIT
W SET LRN=0
FOR A=0:0
SET LRN=$ORDER(^TMP($JOB,LRN))
if LRN=""!(LR("Q"))
QUIT
SET I=0
DO A
+1 QUIT
A FOR B=0:0
SET I=$ORDER(^TMP($JOB,LRN,I))
if I=""!(LR("Q"))
QUIT
SET P=^(I)
SET LRDFN=+$PIECE(P,"^",3)
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !,LRN,?40,$PIECE(P,"^"),?60,I,!?5,$PIECE(P,"^",2)
DO @$SELECT(LRSS="AU":"AU",1:"AP")
WRITE !,LR("%")
+1 QUIT
AP FOR LRI=LRB:0
SET LRI=$ORDER(^LR(LRDFN,LRSS,LRI))
if 'LRI!(LRI>LRE)!(LR("Q"))
QUIT
SET LRX=^(LRI,0)
IF $PIECE($PIECE(LRX,U,6)," ")=LRABV
if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
WRITE !,"Specimen date: ",$$FMTE^XLFDT(+LRX),?40,"Accession number: ",$PIECE(LRX,"^",6)
+1 QUIT
AU SET X=$GET(^LR(LRDFN,"AU"))
IF $PIECE($PIECE(X,U,6)," ")=LRABV
WRITE !,"Autopsy date: ",$$FMTE^XLFDT(+X),?30,"Autopsy number: ",$PIECE(X,"^",6)
+1 QUIT
+2 ;
END DO V^LRU
QUIT
