- LRUL ;AVAMC/REG - PATIENT UTILITY LIST ;6/14/92 11:03
- ;;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)=""
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUL 1457 printed Jan 18, 2025@03:22:16 Page 2
- LRUL ;AVAMC/REG - PATIENT UTILITY LIST ;6/14/92 11:03
- +1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 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 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_"^^^^^^^^"_SSN
- SET ^LRO(69.2,LRAA,7,DUZ,1,"C",PNM,LRDFN)=""
- +2 WRITE !!,"Another patient: "
- SET %=2
- DO YN^LRU
- if %=1
- GOTO G
- +3 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