LRUL.m

LRUL ;AVAMC/REG - PATIENT UTILITY LIST ;6/14/92  11:03 [ 05/15/2003  12:32 PM ]

 ;;5.2T9;LR;*1018*;Nov 17, 2004

 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994

 ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021

 D S,K

G W ! K DIC D ^LRDPA Q:DFN=-1  W !,"Is this the patient " S %=1 D YN^LRU G:%'=1 G

 ;S:'$D(^LRO(69.2,LRAA,7,DUZ,1,0)) ^(0)="^69.3PA^^" I '$D(^(LRDFN,0)) S X=^LRO(69.2,LRAA,7,DUZ,1,0),^(0)=$P(X,"^",1,2)_"^"_LRDFN_"^"_($P(X,"^",4)+1),^(LRDFN,0)=LRDFN_"^"_PNM_"^^^^^^^^"_SSN,^LRO(69.2,LRAA,7,DUZ,1,"C",PNM,LRDFN)=""

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 S:'$D(^LRO(69.2,LRAA,7,DUZ,1,0)) ^(0)="^69.3PA^^" I '$D(^(LRDFN,0)) S X=^LRO(69.2,LRAA,7,DUZ,1,0),^(0)=$P(X,"^",1,2)_"^"_LRDFN_"^"_($P(X,"^",4)+1),^(LRDFN,0)=LRDFN_"^"_PNM_"^^^^^^^^"_HRCN,^LRO(69.2,LRAA,7,DUZ,1,"C",PNM,LRDFN)=""  ;IHS/ANMC/CLS

 ;----- END IHS MODIFICATIONS

 W !!,"Another patient: " S %=2 D YN^LRU G G:%=1

 Q

K I $O(^LRO(69.2,LRAA,7,DUZ,1,0)) D L W $C(7),!,"The above entries not yet printed.  Do you want to delete them " S %=2 D YN^LRU I %'=1 S $P(^LRO(69.2,LRAA,7,DUZ,0),U,2)=LRT Q

EN K ^LRO(69.2,LRAA,7,DUZ) S ^LRO(69.2,LRAA,7,DUZ,0)=DUZ_"^"_LRT,^(1,0)="^69.3PA^^" Q

L W ! S LRDFN=0 F A=1:1 S LRDFN=$O(^LRO(69.2,LRAA,7,DUZ,1,LRDFN)) Q:'LRDFN  S X=^LR(LRDFN,0),Y=$P(X,"^",3),X=^DIC($P(X,U,2),0,"GL"),X=@(X_Y_",0)") W:A#2=1 ! W:A#2=0 ?40 W $P(X,U)," ",$E($P(X,U,9),6,10)

 Q

R Q:$P($G(^LRO(69.2,LRAA,7,DUZ,1,0)),U,4)>0  K ^LRO(69.2,LRAA,7,DUZ) L +^LRO(69.2,LRAA,7) S X=^LRO(69.2,LRAA,7,0),X(1)=$O(^(0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1) L -^LRO(69.2,LRAA,7) Q

 ;

S S X="T",%DT="" D ^%DT S LRT=Y

 S:'$D(^LRO(69.2,LRAA,7,0)) ^(0)="^69.28PA^^" I '$D(^LRO(69.2,LRAA,7,DUZ)) L +^LRO(69.2,LRAA,7) S X=^LRO(69.2,LRAA,7,0),^(0)=$P(X,U,1,2)_U_DUZ_U_($P(X,U,4)+1) L -^LRO(69.2,LRAA,7)

 Q

LRUL      ;AVAMC/REG - PATIENT UTILITY LIST ;6/14/92  11:03 [ 05/15/2003  12:32 PM ]

 +1       ;;5.2T9;LR;*1018*;Nov 17, 2004

 +2       ;;5.2;LAB SERVICE;**247**;Sep 27, 1994

 +3       ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021

 +4        DO S

           DO K

G          WRITE !

           KILL DIC

           DO ^LRDPA

           IF DFN=-1

               QUIT 

           WRITE !,"Is this the patient "

           SET %=1

           DO YN^LRU

           IF %'=1

               GOTO G

 +1       ;S:'$D(^LRO(69.2,LRAA,7,DUZ,1,0)) ^(0)="^69.3PA^^" I '$D(^(LRDFN,0)) S X=^LRO(69.2,LRAA,7,DUZ,1,0),^(0)=$P(X,"^",1,2)_"^"_LRDFN_"^"_($P(X,"^",4)+1),^(LRDFN,0)=LRDFN_"^"_PNM_"^^^^^^^^"_SSN,^LRO(69.2,LRAA,7,DUZ,1,"C",PNM,LRDFN)=""

 +2       ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

 +3       ;IHS/ANMC/CLS

           IF '$DATA(^LRO(69.2,LRAA,7,DUZ,1,0))

               SET ^(0)="^69.3PA^^"

           IF '$DATA(^(LRDFN,0))

               SET X=^LRO(69.2,LRAA,7,DUZ,1,0)

               SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRDFN_"^"_($PIECE(X,"^",4)+1)

               SET ^(LRDFN,0)=LRDFN_"^"_PNM_"^^^^^^^^"_HRCN

               SET ^LRO(69.2,LRAA,7,DUZ,1,"C",PNM,LRDFN)=""

 +4       ;----- END IHS MODIFICATIONS

 +5        WRITE !!,"Another patient: "

           SET %=2

           DO YN^LRU

           IF %=1

               GOTO G

 +6        QUIT 

K          IF $ORDER(^LRO(69.2,LRAA,7,DUZ,1,0))

               DO L

               WRITE $CHAR(7),!,"The above entries not yet printed.  Do you want to delete them "

               SET %=2

               DO YN^LRU

               IF %'=1

                   SET $PIECE(^LRO(69.2,LRAA,7,DUZ,0),U,2)=LRT

                   QUIT 

EN         KILL ^LRO(69.2,LRAA,7,DUZ)

           SET ^LRO(69.2,LRAA,7,DUZ,0)=DUZ_"^"_LRT

           SET ^(1,0)="^69.3PA^^"

           QUIT 

L          WRITE !

           SET LRDFN=0

           FOR A=1:1

               SET LRDFN=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,LRDFN))

               IF 'LRDFN

                   QUIT 

               SET X=^LR(LRDFN,0)

               SET Y=$PIECE(X,"^",3)

               SET X=^DIC($PIECE(X,U,2),0,"GL")

               SET X=@(X_Y_",0)")

               IF A#2=1

                   WRITE !

               IF A#2=0

                   WRITE ?40

               WRITE $PIECE(X,U)," ",$EXTRACT($PIECE(X,U,9),6,10)

 +1        QUIT 

R          IF $PIECE($GET(^LRO(69.2,LRAA,7,DUZ,1,0)),U,4)>0

               QUIT 

           KILL ^LRO(69.2,LRAA,7,DUZ)

           LOCK +^LRO(69.2,LRAA,7)

           SET X=^LRO(69.2,LRAA,7,0)

           SET X(1)=$ORDER(^(0))

           SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)

           LOCK -^LRO(69.2,LRAA,7)

           QUIT 

 +1       ;

S          SET X="T"

           SET %DT=""

           DO ^%DT

           SET LRT=Y

 +1        IF '$DATA(^LRO(69.2,LRAA,7,0))

               SET ^(0)="^69.28PA^^"

           IF '$DATA(^LRO(69.2,LRAA,7,DUZ))

               LOCK +^LRO(69.2,LRAA,7)

               SET X=^LRO(69.2,LRAA,7,0)

               SET ^(0)=$PIECE(X,U,1,2)_U_DUZ_U_($PIECE(X,U,4)+1)

               LOCK -^LRO(69.2,LRAA,7)

 +2        QUIT