LRAPLG ;AVAMC/REG/WTY - AP LOG-IN ;01/23/17 03:16
;;5.2;LAB SERVICE;**72,201,259,462,479,490**;Sep 27, 1994;Build 2
EN ;
;;*
D END
N LREND,D0,DD S LREND=0
;
N LRADD
N LRAPLGX,DOD,FDAIEN,H8,LR6802,LRACC,LRCDT,LRCNT,LREAL,LRORDR
N LRFDA,LRIENLOC,LRNLT,LRNT,LROT,LRPCEVSO,LRPROVL,LRSAMP
N LRSF515,LRSPEC,LRSPTOP,LRTSORU,LRTST,LRUID,ORGMDATZ
N ORIFN,SS,TEST,X,X11,Y,OCXSEG,LRLWC
S LRAPLGX=1,(LRORDR,LRLWC)="WC"
;
D:$G(^LAB(69.9,1,21661)) EN1^LRAPKOE
I $G(LRAPDIAL) K LRAPDIAL D END G EN
D ^LRAP I '$D(Y) D END Q
;;;*
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
D:LRPF="^DPT(" ^LRAPPOW ; for AFIP studies
D ^LRAPLG1 K LRMD,DIC,DIE,DR,LRAPDIAL 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
;;*
K LRAPLGX,DOD,FDAIEN,H8,LR6802,LRACC,LRCDT,LRCNT,LREAL
K LRFDA,LRIENLOC,LRNLT,LRNT,LROT,LRPCEVSO,LRPROVL,LRSAMP
K LRSF515,LRSPEC,LRSPTOP,LRTSORU,LRTST,LRUID,ORGMDAT
K ORIFN,SS,TEST,X,X11,Y
K DA,DFN,DIC,DIE,DR,LR,LRAA,LRAD,LRAPDIAL,LRCAPA,LRDFN,LRDPAF
K LRDPF,LRDTI,LREXP,LRFNAM,LRH,LRMD,LRPF,LRPRAC
K LRSIT,LRSS,LRT,LRW,LRWHN
;;;*
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPLG 2867 printed Dec 13, 2024@02:07:37 Page 2
LRAPLG ;AVAMC/REG/WTY - AP LOG-IN ;01/23/17 03:16
+1 ;;5.2;LAB SERVICE;**72,201,259,462,479,490**;Sep 27, 1994;Build 2
EN ;
+1 ;;*
+2 DO END
+3 NEW LREND,D0,DD
SET LREND=0
+4 ;
+5 NEW LRADD
+6 NEW LRAPLGX,DOD,FDAIEN,H8,LR6802,LRACC,LRCDT,LRCNT,LREAL,LRORDR
+7 NEW LRFDA,LRIENLOC,LRNLT,LRNT,LROT,LRPCEVSO,LRPROVL,LRSAMP
+8 NEW LRSF515,LRSPEC,LRSPTOP,LRTSORU,LRTST,LRUID,ORGMDATZ
+9 NEW ORIFN,SS,TEST,X,X11,Y,OCXSEG,LRLWC
+10 SET LRAPLGX=1
SET (LRORDR,LRLWC)="WC"
+11 ;
+12 if $GET(^LAB(69.9,1,21661))
DO EN1^LRAPKOE
+13 IF $GET(LRAPDIAL)
KILL LRAPDIAL
DO END
GOTO EN
+14 DO ^LRAP
IF '$DATA(Y)
DO END
QUIT
+15 ;;;*
+16 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
+17 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
+18 IF LRCAPA
DO @(LRSS_"^LRAPSWK")
if '$DATA(X)
GOTO END
+19 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
+20 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
+21 SET LRH(2)=$EXTRACT(LRAD,1,3)
SET LRWHN=$EXTRACT(LRAD,2,3)
+22 if '$DATA(^LRO(68,LRAA,1,0))
SET ^(0)="^68.01DA^^0"
+23 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)
+24 if '$DATA(^LRO(68,LRAA,1,LRAD,1,0))
SET ^(0)="^68.02PA^^"
+25 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 ;
+9 IF LRSS="SP"
SET X="SROSPLG"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO ^SROSPLG
+10 ;
+11 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 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"
WRITE !,"Yr:",1700+$EXTRACT(Y,1,3)," Acc#:",X," IN LAB FILE FOR ",$PIECE(@(LRPF_DFN_",0)"),U)," SSN:",$PIECE(^(0),U,9)
DO CK
QUIT
+2 ; for AFIP studies
if LRPF="^DPT("
DO ^LRAPPOW
+3 DO ^LRAPLG1
KILL LRMD,DIC,DIE,DR,LRAPDIAL
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
+1 ;;*
+2 KILL LRAPLGX,DOD,FDAIEN,H8,LR6802,LRACC,LRCDT,LRCNT,LREAL
+3 KILL LRFDA,LRIENLOC,LRNLT,LRNT,LROT,LRPCEVSO,LRPROVL,LRSAMP
+4 KILL LRSF515,LRSPEC,LRSPTOP,LRTSORU,LRTST,LRUID,ORGMDAT
+5 KILL ORIFN,SS,TEST,X,X11,Y
+6 KILL DA,DFN,DIC,DIE,DR,LR,LRAA,LRAD,LRAPDIAL,LRCAPA,LRDFN,LRDPAF
+7 KILL LRDPF,LRDTI,LREXP,LRFNAM,LRH,LRMD,LRPF,LRPRAC
+8 KILL LRSIT,LRSS,LRT,LRW,LRWHN
+9 ;;;*
+10 QUIT
