- LRAPLG1 ;AVAMC/REG/WTY/KLL - LOG-IN CONT. ;07/30/04
- ;;5.2;LAB SERVICE;**1002,1003,1018,1031**;NOV 1, 1997
- ;
- ;;VA LR Patche(s): 72,121,248,308
- ;
- ;Reference to ^%ZOSF("TEST" supported by IA #10096
- ;Reference to ^VA(200 supported by IA #10060
- ;Reference to ^%DT supported by IA #10003
- ;Reference to EN^DDIOL supported by IA #10142
- ;Reference to ^DIE supported by IA #10018
- ;Reference to DISP^SROSPLG supported by IA #893
- ;
- L +^LRO(68,LRAA,1,LRAD):5 I '$T D Q
- .S MSG="Someone else is logging in specimens. "
- .S MSG=MSG_"Please wait and try again."
- .D EN^DDIOL(MSG,"","!!") K MSG
- S LRAN=$P(^LRO(68,LRAA,1,LRAD,1,0),"^",3)
- F X=0:0 S LRAN=LRAN+1 Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
- I $D(^LR(LRXREF,LRH(2),LRABV,LRAN)) F X=0:0 S LRAN=LRAN+1 Q:'$D(^LR(LRXREF,LRH(2),LRABV,LRAN))
- W !!,"Assign ",LRO(68)," (",LRABV,") accession #: ",LRAN," " S %=1 D YN^LRU
- I %<1 L -^LRO(68,LRAA,1,LRAD) G OUT
- I %=2 D OS G:'$D(LRFND) AU K LRFND L -^LRO(68,LRAA,1,LRAD) G OUT
- S X=^LRO(68,LRAA,1,LRAD,1,0),X(2)=$P(X,"^",4)+1
- S ^LRO(68,LRAA,1,LRAD,1,0)=$P(X,"^",1,2)_"^"_LRAN_"^"_X(2)
- S ^LRO(68,LRAA,1,LRAD,1,LRAN,0)=LRDFN,X=LRAN
- L -^LRO(68,LRAA,1,LRAD)
- AU S LRAN=X,LRAC=LRABV_" "_$E(LRAD,2,3)_" "_LRAN I LRSS="AU" D ^LRAUAW Q
- S DA(1)=LRDFN S:'$D(^LR(LRDFN,LRSS,0)) ^(0)="^"_LRSF_"DA^0^0"
- DT W !,"Date/time Specimen taken: "
- W $S($E(LRAD,1,3)=$E(DT,1,3):"NOW// ",1:"")
- R X:DTIME G:X[U!('$T) END
- ; S:X=""&($E(LRAD,1,3)=$E(DT,1,3)) X="N"
- ; S %DT="ETX",%DT(0)="-N" D ^%DT K %DT
- ; G:X["?" DT G:Y=-1 END
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- S:X=""&($E(LRAD,1,3)=$E(DT,1,3)) X="T" S %DT="ETX",%DT(0)="-NOW" D ^%DT K %DT G:X["?" DT G:Y=-1 END ;IHS/ANMC/CLS
- ;----- END IHS MODIFICATIONS
- S LRSD=Y,LRI=9999999-Y
- L +^LR(LRDFN,LRSS):5 I '$T D Q
- .S MSG="This record is locked by another user. "
- .S MSG=MSG_"Please wait and try again."
- .D EN^DDIOL(MSG,"","!!"),X K MSG
- F I $D(^LR(LRDFN,LRSS,LRI,0)) S LRI=LRI-.00001 G F
- S ^LR(LRDFN,LRSS,LRI,0)=LRSD
- S X=^LR(LRDFN,LRSS,0),^(0)=$P(X,"^",1,2)_"^"_LRI_"^"_($P(X,"^",4)+1)
- L -^LR(LRDFN,LRSS)
- S LR(.07)=$S($D(SRDOC):SRDOC,1:"") K SRDOC
- S:LR(.07) LR(.07)=$P($G(^VA(200,LR(.07),0)),"^")
- S DIC(0)="EQLMF",DLAYGO=63,DA=LRI,DIE="^LR(LRDFN,LRSS,"
- D @LR("L"),^DIE K DLAYGO
- I $D(Y)!($D(DTOUT)) D Q
- .W $C(7),!!,"All Prompts not answered <ENTRY DELETED>"
- .K ^LR(LRDFN,LRSS,DA)
- .S X=^LR(LRDFN,LRSS,0),X(1)=$O(^(0))
- .S ^LR(LRDFN,LRSS,0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1)
- .D X
- I LRSS="CY",LRCAPA D CK^LRAPCWK
- I LRSS="SP" S X="SROSPLG" X ^%ZOSF("TEST") I $T D DISP^SROSPLG
- D ^LRUWLF D:LRSS="CY"&LRCAPA ^LRAPCWK D:"SPEM"[LRSS&LRCAPA ^LRAPSWK D:"SPCYEM"[LRSS ^LRSPGD
- D OERR^LR7OB63D
- Q
- X ;from LRAUAW
- K:"CYEMSP"[LRSS ^LR(LRXREF,LRH(2),LRABV,LRAN)
- I LRSS="AU",$D(LRRC) D
- .K ^LR("AAUA",+$E(LRRC,1,3),LRABV,LRAN),^LR("AAU",+LRRC,LRDFN)
- I $D(LRRC),LRRC>1 K:"CYEMSP"[LRSS ^LR(LRXR,LRRC,LRDFN,LRI)
- K LRRC
- END ;from LRAUAW, LRAPLG2
- L +^LRO(68,LRAA,1,LRAD):5 I '$T D Q
- .S MSG="Someone else is logging in specimens. "
- .S MSG=MSG_"Please wait and try again."
- .D EN^DDIOL(MSG,"","!!") K MSG
- K ^LRO(68,LRAA,1,LRAD,1,LRAN),^LRO(68,LRAA,1,"AC",DUZ(2),LRAD,LRAN)
- S X=^LRO(68,LRAA,1,LRAD,1,0),X(1)=$O(^(0)),X(2)=$P(X,"^",4)-1
- S ^LRO(68,LRAA,1,LRAD,1,0)=$P(X,"^",1,2)_"^"_X(1)_"^"_X(2)
- L -^LRO(68,LRAA,1,LRAD)
- Q
- OS R !!,"Enter Accession # : ",X:DTIME I X=""!(X[U) S LRFND=1 Q
- I X'?1N.N!(X<1)!(X>99999) W $C(7),!!,"ENTER A WHOLE NUMBER FROM 1 TO 99999",! G OS
- I $D(^LRO(68,LRAA,1,LRAD,1,X,0)),$P(^(0),U) D ^LRUTELL G OS
- S ^LRO(68,LRAA,1,LRAD,1,X,0)=LRDFN I $D(LRXREF),$D(^LR(LRXREF,LRH(2),LRABV,X)) D ^LRAPLG2 S LRFND=1
- Q
- OUT Q
- LRAPLG1 ;AVAMC/REG/WTY/KLL - LOG-IN CONT. ;07/30/04
- +1 ;;5.2;LAB SERVICE;**1002,1003,1018,1031**;NOV 1, 1997
- +2 ;
- +3 ;;VA LR Patche(s): 72,121,248,308
- +4 ;
- +5 ;Reference to ^%ZOSF("TEST" supported by IA #10096
- +6 ;Reference to ^VA(200 supported by IA #10060
- +7 ;Reference to ^%DT supported by IA #10003
- +8 ;Reference to EN^DDIOL supported by IA #10142
- +9 ;Reference to ^DIE supported by IA #10018
- +10 ;Reference to DISP^SROSPLG supported by IA #893
- +11 ;
- +12 LOCK +^LRO(68,LRAA,1,LRAD):5
- IF '$TEST
- Begin DoDot:1
- +13 SET MSG="Someone else is logging in specimens. "
- +14 SET MSG=MSG_"Please wait and try again."
- +15 DO EN^DDIOL(MSG,"","!!")
- KILL MSG
- End DoDot:1
- QUIT
- +16 SET LRAN=$PIECE(^LRO(68,LRAA,1,LRAD,1,0),"^",3)
- +17 FOR X=0:0
- SET LRAN=LRAN+1
- IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
- QUIT
- +18 IF $DATA(^LR(LRXREF,LRH(2),LRABV,LRAN))
- FOR X=0:0
- SET LRAN=LRAN+1
- IF '$DATA(^LR(LRXREF,LRH(2),LRABV,LRAN))
- QUIT
- +19 WRITE !!,"Assign ",LRO(68)," (",LRABV,") accession #: ",LRAN," "
- SET %=1
- DO YN^LRU
- +20 IF %<1
- LOCK -^LRO(68,LRAA,1,LRAD)
- GOTO OUT
- +21 IF %=2
- DO OS
- IF '$DATA(LRFND)
- GOTO AU
- KILL LRFND
- LOCK -^LRO(68,LRAA,1,LRAD)
- GOTO OUT
- +22 SET X=^LRO(68,LRAA,1,LRAD,1,0)
- SET X(2)=$PIECE(X,"^",4)+1
- +23 SET ^LRO(68,LRAA,1,LRAD,1,0)=$PIECE(X,"^",1,2)_"^"_LRAN_"^"_X(2)
- +24 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,0)=LRDFN
- SET X=LRAN
- +25 LOCK -^LRO(68,LRAA,1,LRAD)
- AU SET LRAN=X
- SET LRAC=LRABV_" "_$EXTRACT(LRAD,2,3)_" "_LRAN
- IF LRSS="AU"
- DO ^LRAUAW
- QUIT
- +1 SET DA(1)=LRDFN
- IF '$DATA(^LR(LRDFN,LRSS,0))
- SET ^(0)="^"_LRSF_"DA^0^0"
- DT WRITE !,"Date/time Specimen taken: "
- +1 WRITE $SELECT($EXTRACT(LRAD,1,3)=$EXTRACT(DT,1,3):"NOW// ",1:"")
- +2 READ X:DTIME
- IF X[U!('$TEST)
- GOTO END
- +3 ; S:X=""&($E(LRAD,1,3)=$E(DT,1,3)) X="N"
- +4 ; S %DT="ETX",%DT(0)="-N" D ^%DT K %DT
- +5 ; G:X["?" DT G:Y=-1 END
- +6 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +7 ;IHS/ANMC/CLS
- IF X=""&($EXTRACT(LRAD,1,3)=$EXTRACT(DT,1,3))
- SET X="T"
- SET %DT="ETX"
- SET %DT(0)="-NOW"
- DO ^%DT
- KILL %DT
- IF X["?"
- GOTO DT
- IF Y=-1
- GOTO END
- +8 ;----- END IHS MODIFICATIONS
- +9 SET LRSD=Y
- SET LRI=9999999-Y
- +10 LOCK +^LR(LRDFN,LRSS):5
- IF '$TEST
- Begin DoDot:1
- +11 SET MSG="This record is locked by another user. "
- +12 SET MSG=MSG_"Please wait and try again."
- +13 DO EN^DDIOL(MSG,"","!!")
- DO X
- KILL MSG
- End DoDot:1
- QUIT
- F IF $DATA(^LR(LRDFN,LRSS,LRI,0))
- SET LRI=LRI-.00001
- GOTO F
- +1 SET ^LR(LRDFN,LRSS,LRI,0)=LRSD
- +2 SET X=^LR(LRDFN,LRSS,0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRI_"^"_($PIECE(X,"^",4)+1)
- +3 LOCK -^LR(LRDFN,LRSS)
- +4 SET LR(.07)=$SELECT($DATA(SRDOC):SRDOC,1:"")
- KILL SRDOC
- +5 IF LR(.07)
- SET LR(.07)=$PIECE($GET(^VA(200,LR(.07),0)),"^")
- +6 SET DIC(0)="EQLMF"
- SET DLAYGO=63
- SET DA=LRI
- SET DIE="^LR(LRDFN,LRSS,"
- +7 DO @LR("L")
- DO ^DIE
- KILL DLAYGO
- +8 IF $DATA(Y)!($DATA(DTOUT))
- Begin DoDot:1
- +9 WRITE $CHAR(7),!!,"All Prompts not answered <ENTRY DELETED>"
- +10 KILL ^LR(LRDFN,LRSS,DA)
- +11 SET X=^LR(LRDFN,LRSS,0)
- SET X(1)=$ORDER(^(0))
- +12 SET ^LR(LRDFN,LRSS,0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
- +13 DO X
- End DoDot:1
- QUIT
- +14 IF LRSS="CY"
- IF LRCAPA
- DO CK^LRAPCWK
- +15 IF LRSS="SP"
- SET X="SROSPLG"
- XECUTE ^%ZOSF("TEST")
- IF $TEST
- DO DISP^SROSPLG
- +16 DO ^LRUWLF
- IF LRSS="CY"&LRCAPA
- DO ^LRAPCWK
- IF "SPEM"[LRSS&LRCAPA
- DO ^LRAPSWK
- IF "SPCYEM"[LRSS
- DO ^LRSPGD
- +17 DO OERR^LR7OB63D
- +18 QUIT
- X ;from LRAUAW
- +1 IF "CYEMSP"[LRSS
- KILL ^LR(LRXREF,LRH(2),LRABV,LRAN)
- +2 IF LRSS="AU"
- IF $DATA(LRRC)
- Begin DoDot:1
- +3 KILL ^LR("AAUA",+$EXTRACT(LRRC,1,3),LRABV,LRAN),^LR("AAU",+LRRC,LRDFN)
- End DoDot:1
- +4 IF $DATA(LRRC)
- IF LRRC>1
- IF "CYEMSP"[LRSS
- KILL ^LR(LRXR,LRRC,LRDFN,LRI)
- +5 KILL LRRC
- END ;from LRAUAW, LRAPLG2
- +1 LOCK +^LRO(68,LRAA,1,LRAD):5
- IF '$TEST
- Begin DoDot:1
- +2 SET MSG="Someone else is logging in specimens. "
- +3 SET MSG=MSG_"Please wait and try again."
- +4 DO EN^DDIOL(MSG,"","!!")
- KILL MSG
- End DoDot:1
- QUIT
- +5 KILL ^LRO(68,LRAA,1,LRAD,1,LRAN),^LRO(68,LRAA,1,"AC",DUZ(2),LRAD,LRAN)
- +6 SET X=^LRO(68,LRAA,1,LRAD,1,0)
- SET X(1)=$ORDER(^(0))
- SET X(2)=$PIECE(X,"^",4)-1
- +7 SET ^LRO(68,LRAA,1,LRAD,1,0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_X(2)
- +8 LOCK -^LRO(68,LRAA,1,LRAD)
- +9 QUIT
- OS READ !!,"Enter Accession # : ",X:DTIME
- IF X=""!(X[U)
- SET LRFND=1
- QUIT
- +1 IF X'?1N.N!(X<1)!(X>99999)
- WRITE $CHAR(7),!!,"ENTER A WHOLE NUMBER FROM 1 TO 99999",!
- GOTO OS
- +2 IF $DATA(^LRO(68,LRAA,1,LRAD,1,X,0))
- IF $PIECE(^(0),U)
- DO ^LRUTELL
- GOTO OS
- +3 SET ^LRO(68,LRAA,1,LRAD,1,X,0)=LRDFN
- IF $DATA(LRXREF)
- IF $DATA(^LR(LRXREF,LRH(2),LRABV,X))
- DO ^LRAPLG2
- SET LRFND=1
- +4 QUIT
- OUT QUIT
