- LRUDPT ; IHS/DIR/FJE - POW PTS 2/18/93 12:36 ;
- ;;5.2;LR;**1013**;JUL 15, 2002
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- D XR^LRU
- W !!?25,LRAA(1)," SEARCH FOR",!?28,"PRISONER OF WAR VETS",!!
- D B^LRU Q:Y<0 S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
- DEV S ZTRTN="QUE^LRUDPT" D BEG^LRUTL Q:POP!($D(ZTSK))
- QUE U IO K ^TMP($J) S Z(4)=0 D L^LRU,HDR
- F A=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:LRSDT<1!(LRSDT>LRLDT) D LRDFN
- D WRT W:IO'=IO(0) @IOF K N,P,LRP,LRXREF,LRXR,^TMP($J) D END^LRUTL Q
- LRDFN F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:LRDFN<1 D CK
- Q
- CK Q:$P(^LR(LRDFN,0),"^",2)'=2 S DFN=$P(^(0),"^",3),S(4)=""
- POW I $D(^DPT(DFN,.52)),$P(^(.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
- D:$Y>60 HDR I $L(S(4)) S X=^DPT(DFN,0),LRDPF=2,LRP=$P(X,"^"),SSN=$P(X,"^",9),Y=$P(X,"^",3) D D^LRU,SSN^LRU S ^TMP($J,LRP,SSN)=Y_"^"_S(4)
- Q
- HDR S Z(4)=Z(4)+1,%DT="T",X="N" D ^%DT,D^LRU W @IOF,!?23,"LABORATORY SERVICE ",$$INS^LRU,!,Y,?22,LRAA(1)," Special patients ",?73,"Pg: ",Z(4),!,"From: ",LRSTR," to ",LRLST,!
- W !,"Patient",?40,"DOB",?60,"ID",!,LR("%") Q
- WRT S N=0 F A=0:0 S N=$O(^TMP($J,N)) Q:N="" S I=0 F B=0:0 S I=$O(^TMP($J,N,I)) Q:I="" S P=^(I) D:$Y>60 HDR W !,N,?40,$P(P,"^"),?60,I,!?5,$P(P,"^",2)
- Q
- LRUDPT ; IHS/DIR/FJE - POW PTS 2/18/93 12:36 ;
- +1 ;;5.2;LR;**1013**;JUL 15, 2002
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 DO XR^LRU
- +5 WRITE !!?25,LRAA(1)," SEARCH FOR",!?28,"PRISONER OF WAR VETS",!!
- +6 DO B^LRU
- IF Y<0
- QUIT
- SET LRSDT=LRSDT-.01
- SET LRLDT=LRLDT+.99
- DEV SET ZTRTN="QUE^LRUDPT"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- QUIT
- QUE USE IO
- KILL ^TMP($JOB)
- SET Z(4)=0
- DO L^LRU
- DO HDR
- +1 FOR A=0:0
- SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
- IF LRSDT<1!(LRSDT>LRLDT)
- QUIT
- DO LRDFN
- +2 DO WRT
- IF IO'=IO(0)
- WRITE @IOF
- KILL N,P,LRP,LRXREF,LRXR,^TMP($JOB)
- DO END^LRUTL
- QUIT
- LRDFN FOR LRDFN=0:0
- SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))
- IF LRDFN<1
- QUIT
- DO CK
- +1 QUIT
- CK IF $PIECE(^LR(LRDFN,0),"^",2)'=2
- QUIT
- SET DFN=$PIECE(^(0),"^",3)
- SET S(4)=""
- POW IF $DATA(^DPT(DFN,.52))
- IF $PIECE(^(.52),"^",5)="Y"
- 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
- +1 IF $Y>60
- DO HDR
- IF $LENGTH(S(4))
- SET X=^DPT(DFN,0)
- SET LRDPF=2
- SET LRP=$PIECE(X,"^")
- SET SSN=$PIECE(X,"^",9)
- SET Y=$PIECE(X,"^",3)
- DO D^LRU
- DO SSN^LRU
- SET ^TMP($JOB,LRP,SSN)=Y_"^"_S(4)
- +2 QUIT
- HDR SET Z(4)=Z(4)+1
- SET %DT="T"
- SET X="N"
- DO ^%DT
- DO D^LRU
- WRITE @IOF,!?23,"LABORATORY SERVICE ",$$INS^LRU,!,Y,?22,LRAA(1)," Special patients ",?73,"Pg: ",Z(4),!,"From: ",LRSTR," to ",LRLST,!
- +1 WRITE !,"Patient",?40,"DOB",?60,"ID",!,LR("%")
- QUIT
- WRT SET N=0
- FOR A=0:0
- SET N=$ORDER(^TMP($JOB,N))
- IF N=""
- QUIT
- SET I=0
- FOR B=0:0
- SET I=$ORDER(^TMP($JOB,N,I))
- IF I=""
- QUIT
- SET P=^(I)
- IF $Y>60
- DO HDR
- WRITE !,N,?40,$PIECE(P,"^"),?60,I,!?5,$PIECE(P,"^",2)
- +1 QUIT
