LRAPLG ;AVAMC/REG/WTY - AP LOG-IN ;10/23/01
;;5.2;LAB SERVICE;**1002,1006,1030,1031**;NOV 01, 1997
;
;;VA LR Patch(s): 72,201,259
;
D ^LRAP Q:'$D(Y) S LR("L")=LRSS_"^LRAP" I LRCAPA,"AUSP"[LRSS S X=$S(LRSS="SP":"H & E STAIN",1:"AUTOPSY H & E") D X^LRUWK G:'$D(X) END S LRW("H&E")=LRT K LRT
I LRCAPA,LRSS="EM" S X="THICK SECTION EM" D X^LRUWK G:'$D(X) END S X=11 D SET S LRW("SS")=LRT_U_X S X="GRID EM" D X^LRUWK G:'$D(X) END S X=12 D SET S LRW("G")=LRT_U_X K LRT
I LRCAPA D @(LRSS_"^LRAPSWK") G:'$D(X) END
D:"SPEMCY"[LRSS A^LRAPWU W !!,"Log-In for ",LRH(0)," " S %=1 D YN^LRU Q:%<1 S LRAA(3)=1 D XR^LRU
I %=2 S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT K %DT Q:Y<1 S LRAD=$E(Y,1,3)_"0000",Y=LRAD D D^LRU S LRH(0)=Y
S LRH(2)=$E(LRAD,1,3),LRWHN=$E(LRAD,2,3)
S:'$D(^LRO(68,LRAA,1,0)) ^(0)="^68.01DA^^0"
S:'$D(^LRO(68,LRAA,1,LRAD,0)) ^(0)=LRAD,^LRO(68,LRAA,1,0)=$P(^LRO(68,LRAA,1,0),"^",1,2)_"^"_LRAD_"^"_($P(^(0),"^",4)+1)
S:'$D(^LRO(68,LRAA,1,LRAD,1,0)) ^(0)="^68.02PA^^"
S %DT="",X="T-4" D ^%DT S LRDTI=9999999-Y
GETP W ! S LRSIT="",LRDPAF=1 K DIC
D ^LRDPA G:LRDFN<1 END
S:'+$G(LRPRAC) LRPRAC(1)=""
I +$G(LRPRAC) S X=LRPRAC D D^LRUA S LRPRAC(1)=X
I LRSS="SP" S X=0 F S X=$O(^LR(LRDFN,LRSS,X)) Q:'X!(X>LRDTI) D
.S Y=^LR(LRDFN,LRSS,X,0)
.W $C(7),!?6,"Accession number assigned for ",$$FMTE^XLFDT(Y,"D")
.W " is: ",$P(Y,"^",6)
I LRSS="SP" S X="SROSPLG" X ^%ZOSF("TEST") I $T D ^SROSPLG
D ADD G GETP
ADD I LRSS="AU",'$D(LREXP) W $C(7),!!,"NO DATE DIED ENTERED IN ",LRFNAM," FILE",! Q:+LRDPF=2 S DIE=+LRDPF,DA=DFN,DR=.351 D ^DIE Q:$D(Y) S LREXP=X
; I LRSS="AU",$D(^LR(LRDFN,"AU")),$P(^("AU"),U,6) S Y=^("AU"),X=+$P(Y,U,6),Y(1)=$E(Y,1,3)_"0000" W !,"Yr:",1700+$E(Y,1,3)," Acc#:",X," IN LAB FILE FOR ",$P(@(LRPF_DFN_",0)"),U)," SSN:",$P(^(0),U,9) D CK Q
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
I LRSS="AU",$D(^LR(LRDFN,"AU")),$P(^("AU"),U,6) S Y=^("AU"),X=+$P(Y,U,6),Y(1)=$E(Y,1,3)_"0000" D Q
. W !,"Yr:",1700+$E(Y,1,3)
. W " Acc#:",X," IN LAB FILE FOR "
. W $P(@(LRPF_DFN_",0)"),U)
. W " HRCN:",HRCN
. D CK
; ----- END IHS/MSC/MKK - LR*5.2*1031
;
D:LRPF="^DPT(" ^LRAPPOW ; for AFIP studies
D ^LRAPLG1 K LRMD,DIC,DIE,DR Q
CK I +$G(^LRO(68,LRAA,1,Y(1),1,X,0))=LRDFN W $C(7),!!?20,"Also in accession file" Q
W !,"Enter in Accession File " S %=2 D YN^LRU D:%=1 ^LRAPLG2 Q
SET S X=$P($G(^LRO(69.2,LRAA,0)),"^",X) S:'X X=1 Q
END D V^LRU Q
LRAPLG ;AVAMC/REG/WTY - AP LOG-IN ;10/23/01
+1 ;;5.2;LAB SERVICE;**1002,1006,1030,1031**;NOV 01, 1997
+2 ;
+3 ;;VA LR Patch(s): 72,201,259
+4 ;
+5 DO ^LRAP
IF '$DATA(Y)
QUIT
SET LR("L")=LRSS_"^LRAP"
IF LRCAPA
IF "AUSP"[LRSS
SET X=$SELECT(LRSS="SP":"H & E STAIN",1:"AUTOPSY H & E")
DO X^LRUWK
IF '$DATA(X)
GOTO END
SET LRW("H&E")=LRT
KILL LRT
+6 IF LRCAPA
IF LRSS="EM"
SET X="THICK SECTION EM"
DO X^LRUWK
IF '$DATA(X)
GOTO END
SET X=11
DO SET
SET LRW("SS")=LRT_U_X
SET X="GRID EM"
DO X^LRUWK
IF '$DATA(X)
GOTO END
SET X=12
DO SET
SET LRW("G")=LRT_U_X
KILL LRT
+7 IF LRCAPA
DO @(LRSS_"^LRAPSWK")
IF '$DATA(X)
GOTO END
+8 IF "SPEMCY"[LRSS
DO A^LRAPWU
WRITE !!,"Log-In for ",LRH(0)," "
SET %=1
DO YN^LRU
IF %<1
QUIT
SET LRAA(3)=1
DO XR^LRU
+9 IF %=2
SET %DT="AE"
SET %DT(0)="-N"
SET %DT("A")="Enter YEAR: "
DO ^%DT
KILL %DT
IF Y<1
QUIT
SET LRAD=$EXTRACT(Y,1,3)_"0000"
SET Y=LRAD
DO D^LRU
SET LRH(0)=Y
+10 SET LRH(2)=$EXTRACT(LRAD,1,3)
SET LRWHN=$EXTRACT(LRAD,2,3)
+11 IF '$DATA(^LRO(68,LRAA,1,0))
SET ^(0)="^68.01DA^^0"
+12 IF '$DATA(^LRO(68,LRAA,1,LRAD,0))
SET ^(0)=LRAD
SET ^LRO(68,LRAA,1,0)=$PIECE(^LRO(68,LRAA,1,0),"^",1,2)_"^"_LRAD_"^"_($PIECE(^(0),"^",4)+1)
+13 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,0))
SET ^(0)="^68.02PA^^"
+14 SET %DT=""
SET X="T-4"
DO ^%DT
SET LRDTI=9999999-Y
GETP WRITE !
SET LRSIT=""
SET LRDPAF=1
KILL DIC
+1 DO ^LRDPA
IF LRDFN<1
GOTO END
+2 IF '+$GET(LRPRAC)
SET LRPRAC(1)=""
+3 IF +$GET(LRPRAC)
SET X=LRPRAC
DO D^LRUA
SET LRPRAC(1)=X
+4 IF LRSS="SP"
SET X=0
FOR
SET X=$ORDER(^LR(LRDFN,LRSS,X))
IF 'X!(X>LRDTI)
QUIT
Begin DoDot:1
+5 SET Y=^LR(LRDFN,LRSS,X,0)
+6 WRITE $CHAR(7),!?6,"Accession number assigned for ",$$FMTE^XLFDT(Y,"D")
+7 WRITE " is: ",$PIECE(Y,"^",6)
End DoDot:1
+8 IF LRSS="SP"
SET X="SROSPLG"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO ^SROSPLG
+9 DO ADD
GOTO GETP
ADD IF LRSS="AU"
IF '$DATA(LREXP)
WRITE $CHAR(7),!!,"NO DATE DIED ENTERED IN ",LRFNAM," FILE",!
IF +LRDPF=2
QUIT
SET DIE=+LRDPF
SET DA=DFN
SET DR=.351
DO ^DIE
IF $DATA(Y)
QUIT
SET LREXP=X
+1 ; I LRSS="AU",$D(^LR(LRDFN,"AU")),$P(^("AU"),U,6) S Y=^("AU"),X=+$P(Y,U,6),Y(1)=$E(Y,1,3)_"0000" W !,"Yr:",1700+$E(Y,1,3)," Acc#:",X," IN LAB FILE FOR ",$P(@(LRPF_DFN_",0)"),U)," SSN:",$P(^(0),U,9) D CK Q
+2 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+3 IF LRSS="AU"
IF $DATA(^LR(LRDFN,"AU"))
IF $PIECE(^("AU"),U,6)
SET Y=^("AU")
SET X=+$PIECE(Y,U,6)
SET Y(1)=$EXTRACT(Y,1,3)_"0000"
Begin DoDot:1
+4 WRITE !,"Yr:",1700+$EXTRACT(Y,1,3)
+5 WRITE " Acc#:",X," IN LAB FILE FOR "
+6 WRITE $PIECE(@(LRPF_DFN_",0)"),U)
+7 WRITE " HRCN:",HRCN
+8 DO CK
End DoDot:1
QUIT
+9 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+10 ;
+11 ; for AFIP studies
IF LRPF="^DPT("
DO ^LRAPPOW
+12 DO ^LRAPLG1
KILL LRMD,DIC,DIE,DR
QUIT
CK IF +$GET(^LRO(68,LRAA,1,Y(1),1,X,0))=LRDFN
WRITE $CHAR(7),!!?20,"Also in accession file"
QUIT
+1 WRITE !,"Enter in Accession File "
SET %=2
DO YN^LRU
IF %=1
DO ^LRAPLG2
QUIT
SET SET X=$PIECE($GET(^LRO(69.2,LRAA,0)),"^",X)
IF 'X
SET X=1
QUIT
END DO V^LRU
QUIT
