source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPLG.m@ 1211

Last change on this file since 1211 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.0 KB
Line 
1LRAPLG ;AVAMC/REG/WTY - AP LOG-IN ;10/23/01
2 ;;5.2;LAB SERVICE;**72,201,259**;Sep 27, 1994
3 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
4 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
5 I LRCAPA D @(LRSS_"^LRAPSWK") G:'$D(X) END
6 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
7 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
8 S LRH(2)=$E(LRAD,1,3),LRWHN=$E(LRAD,2,3)
9 S:'$D(^LRO(68,LRAA,1,0)) ^(0)="^68.01DA^^0"
10 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)
11 S:'$D(^LRO(68,LRAA,1,LRAD,1,0)) ^(0)="^68.02PA^^"
12 S %DT="",X="T-4" D ^%DT S LRDTI=9999999-Y
13GETP W ! S LRSIT="",LRDPAF=1 K DIC
14 D ^LRDPA G:LRDFN<1 END
15 S:'+$G(LRPRAC) LRPRAC(1)=""
16 I +$G(LRPRAC) S X=LRPRAC D D^LRUA S LRPRAC(1)=X
17 I LRSS="SP" S X=0 F S X=$O(^LR(LRDFN,LRSS,X)) Q:'X!(X>LRDTI) D
18 .S Y=^LR(LRDFN,LRSS,X,0)
19 .W $C(7),!?6,"Accession number assigned for ",$$FMTE^XLFDT(Y,"D")
20 .W " is: ",$P(Y,"^",6)
21 I LRSS="SP" S X="SROSPLG" X ^%ZOSF("TEST") I $T D ^SROSPLG
22 D ADD G GETP
23ADD 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
24 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
25 D:LRPF="^DPT(" ^LRAPPOW ; for AFIP studies
26 D ^LRAPLG1 K LRMD,DIC,DIE,DR Q
27CK I +$G(^LRO(68,LRAA,1,Y(1),1,X,0))=LRDFN W $C(7),!!?20,"Also in accession file" Q
28 W !,"Enter in Accession File " S %=2 D YN^LRU D:%=1 ^LRAPLG2 Q
29SET S X=$P($G(^LRO(69.2,LRAA,0)),"^",X) S:'X X=1 Q
30END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.