- 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
