Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRU

LRU.m

Go to the documentation of this file.
  1. LRU ;AVAMC/REG/WTY - LAB UTILITY; 9/25/00 [ 04/10/2003 10:10 AM ]
  1. ;;5.2T9;LR;**1002,1006,1009,1018**;Nov 17, 2004
  1. ;;5.2;LAB SERVICE;**1,72,201,248**;Sep 27, 1994
  1. ;
  1. ;Reference to ^DIC(4 supported by IA #10090
  1. ;Reference to ^XMB(1 supported by IA #10091
  1. ;Reference to ^VA(200 supported by IA #10060
  1. ;Reference to ^%DT supported by IA #10003
  1. ;Reference to ^%ZIS supported by IA #10086
  1. ;Reference to ^DIC supported by IA #10006
  1. ;Reference to ^DIE supported by IA #10018
  1. ;Reference to PID^VADPT6 supported by IA #10062
  1. ;Reference to $$FMTE^XLFDT supported by IA #10103
  1. ;
  1. S X="T",%DT="" D ^%DT,D S H(10)=Y Q
  1. ;
  1. LOCK ;Set and kill lock for ^DIE call. If lock fails LR("CK")=1 is set.
  1. N LRLOKVAR
  1. I '$D(DIE) S LR("CK")=1 Q
  1. D CK I '$G(LR("CK")) D ^DIE K LR("CK") D FRE
  1. Q
  1. CK D:$D(LRLOKVAR)#2 FRE S LRLOKVAR=DIE_DA_")" L +@(LRLOKVAR):1
  1. I '$T D
  1. . W !,$C(7),"ANOTHER TERMINAL IS EDITING THIS ENTRY!" S LR("CK")=1
  1. . K LRLOKVAR
  1. Q
  1. FRE I $D(LRLOKVAR) L -@(LRLOKVAR) K LRLOKVAR
  1. Q
  1. ;
  1. F ;
  1. S LRQ=LRQ+1,X="N",%DT="T" D ^%DT,D^LRU
  1. ;Suppress unnecessary form feeds
  1. I $G(LRSS)'="BB" W:IOST?1"C".E!($D(LR("F"))) @IOF
  1. W:$G(LRSS)="BB" @IOF
  1. W !,Y,?22,LRQ(1),?(IOM-10),"Pg: ",LRQ
  1. ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1. ;POSSIBLY NOT NEEDED WITH NEW VA CODE ABOVE???
  1. ;W @IOF,!,Y,?22,LRQ(1),?(IOM-10),"Pg: ",LRQ Q ;IHS/DIR/FJE ADD THE IOF BACK IN
  1. ;----- END IHS MODIFICATIONS
  1. Q
  1. M R !,"'^' TO STOP: ",X:DTIME S:'$T!(X["^") LR("Q")=1 W $C(13),$J("",15),$C(13) Q
  1. ;
  1. T ; Returns the Month/Day
  1. Q:'Y S Y=Y_"000",Y=$E(Y,4,5)_"/"_$E(Y,6,7)_$S(Y[".":" "_$E(Y,9,10)_":"_$E(Y,11,12),1:"")
  1. Q
  1. A ; Returns Date in format mm/dd/yyyy with time if a time is passed.
  1. Q:'Y S Y=$$FMTE^XLFDT(Y,"5M")
  1. I $L($P(Y,"/"))=1 S $P(Y,"/")="0"_$P(Y,"/") ;--> pad for 2 digit day
  1. I $L($P(Y,"/",2))=1 S $P(Y,"/",2)="0"_$P(Y,"/",2) ;--> pad for 2 digit month
  1. Q
  1. ;
  1. D ; Returns date in eye-readable month format
  1. S Y=$TR($$FMTE^XLFDT(Y,"M"),"@"," ")
  1. Q
  1. DA ; Returns date in eye-readable month format
  1. S Y=$$FMTE^XLFDT(Y,"M")
  1. Q
  1. ;
  1. DT ; If Blood Bank maintain existing display, else display 4 digit year.
  1. I $G(LRSS)="BB" S Y=Y_"000",Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "_$S(Y[".":$E(Y,9,10)_":"_$E(Y,11,12),1:"") Q
  1. D A Q
  1. ;
  1. SSN ;
  1. S (SSN,SSN(1),SSN(2))=$G(SSN)
  1. I '$G(LRDPF),$G(LRDFN) S:$P($G(^LR(+LRDFN,0)),U,2) LRDPF=+$P(^(0),U,2)
  1. ;S (VA("BID"),VA("PID"))="" G:'$G(LRDPF)!(+$G(LRDPF)'=2) SSNFM
  1. ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1. S (HRCN,VA("BID"),VA("PID"))="" G:'$G(LRDPF)!(+$G(LRDPF)'=2) SSNFM ;IHS/ANMC/CLS 11/1/95
  1. ;----- END IHS MODIFICATIONS
  1. N I,X,Y,N
  1. ;I $D(DFN) D PID^VADPT6
  1. ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1. ;I $D(DFN) D PID^BLRDPT6 ;IHS/OIRM TUC/MJL
  1. I $D(DFN) D @$S($$ISPIMS^BLRUTIL:"PID^VADPT6",1:"PID^BLRDPT6")
  1. ;----- END IHS MODIFICATIONS
  1. SSNFM S SSN(2)=SSN
  1. I $L(DUZ("AG")),"NAFARMY"[DUZ("AG") S SSN=$S($L(SSN)<11:$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10),1:$E(SSN,10,11)_"/"_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)) S SSN(1)=$S($P(SSN,"-",3):$P(SSN,"-",3),1:$E(SSN,9,12)) Q
  1. S:$L(SSN)>8 SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,99) S SSN(1)=$S($P(SSN,"-",3):$P(SSN,"-",3),$L($E(SSN,($L(SSN)-3),$L(SSN))):$E(SSN,($L(SSN)-3),$L(SSN)),1:"????") S:'$L(SSN) SSN="?" Q
  1. ;
  1. B ;D LRU S %DT="AEX",%DT(0)="-N",%DT("A")="Start with Date TODAY// " D ^%DT K %DT I X="" S Y=DT W H(10)
  1. ;----- BEGIN IHS MODIFICATIONS LR*5.2*!018
  1. D LRU S %DT="AEX",%DT(0)="-N",%DT("A")="Start with Date: TODAY// " D ^%DT K %DT I X="" S Y=DT W H(10) ;IHS/ANMC/CLS 11/1/95
  1. ;----- END IHS MODIFICATIONS
  1. Q:Y<1 S LRSDT=Y
  1. ;S %DT="AEX",%DT("A")="Go to Date TODAY// " D ^%DT K %DT I X="" S Y=DT W H(10)
  1. ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1. S %DT="AEX",%DT("A")="Go back to Date TODAY// " D ^%DT K %DT I X="" S Y=DT W H(10) ;IHS/ANMC/CLS 11/1/95
  1. ;----- END IHS MODIFICATIONS
  1. Q:Y<1 S LRLDT=Y I LRSDT>LRLDT S X=LRSDT,LRSDT=LRLDT,LRLDT=X
  1. S Y=LRSDT D D^LRU S LRSTR=Y,Y=LRLDT D D^LRU S LRLST=Y Q
  1. ;
  1. YN W "? ",$P("YES// ^NO// ","^",%) S LR("%1")=%
  1. RX R %Y:$S($D(DTIME):DTIME,1:99999) E S DTOUT=1,%Y="^" W $C(7)
  1. S:%Y]""!'% %=$A(%Y),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0)
  1. I %Y="@"!(%Y="S") S %=-1 Q
  1. I '%,%Y]"" W $C(7),!?4,"ANSWER 'YES', 'NO', '^', '@'",!?4,"or press RETURN key to accept default response (if one)" S:$D(LR("%1")) %=LR("%1") W !! G YN
  1. W:$X>73 ! W $P(" (YES)^ (NO)","^",%) K LR("%1") Q
  1. ;
  1. XR Q:'$D(LRSS) S LRXR="A"_LRSS,LRXREF=LRXR_"A" Q
  1. ;
  1. WAIT W !!,"..."
  1. W $P("HMMM^EXCUSE ME ^SORRY","^",$R(3)+1),", ",$P("THIS MAY TAKE A WHILE^LET ME PUT YOU ON 'HOLD' ^HOLD ON^JUST A MOMENT PLEASE^I'M WORKING AS FAST AS I CAN^LET ME THINK ABOUT THAT ","^",$R(6)+1)_"..."
  1. H 1 Q
  1. ;
  1. K K A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z Q
  1. ;
  1. V D K
  1. K %,ZTRTN,LRWHO,AGE,DIC,DLAYGO,DIE,DR,DFN,LRSDT,LRLDT,LRSTR,LRLST,LRXR
  1. K LRXREF,LRADM,LRADX,LRABV,LRAWRD,LRAX,LRAD,LRDPAF,LRFNAM,LRMD,LRPF
  1. K LRPFN,LRSVC,LRID,LRAP,LRSAV,LREP,LRDTI,LRODT,LRSN,LRBL,LRCPT,%Y,%X
  1. K LRFND,LRPPT,LRIDT,LRPMD,LR,LRA,LRB,LRC,LRD,LRE,LRF,LRG,LRH,LRI,LRJ
  1. K LRK,LRL,LRM,LRN,LRO,LRP,LRQ,LRR,LRS,LRT,LRU,LRV,LRW,LRX,LRY,LRZ,ZTSK
  1. K ZTRTN,ZTSAVE,ZTDESC,LRAU,LRFLN,LRLIDT,LRND,LRNO,LRST,LRTK,LRWW,LRAC
  1. K DIWL,DIWR,DIWF,LRCAP,LRCAPA,LRCAPLOC,LRPRAC,LRRMD,^UTILITY($J)
  1. K ^TMP($J),^TMP("LRBL",$J),DIWF,D0,LRDFN,LRSF,DQ,LR,LRAN,DA,DX,DOB,SEX
  1. K LRAA,LRSOP,LROPT,LRRH,SSN,LRLLOC,LRDPF,LREND,LREXP,LRTOD,LRABO
  1. K LRPABO,LRPRH,LRSS,PNM,DE,DG,DA,LRCS,LRRC,LRSIT,LRWHN,POP,LRSA,LRIFN
  1. K LRBLT,LRQA,DIR,DIRUT,LRSD,LRPTF,LRADM,LRWARD,LRTS,LRDATE,LROLLOC,VA
  1. K VAIN,VADM,D1,DI,LRWD,LRRB,LRTREA,LRWRD,LRLOKVAR,LRAPX,LRSET,LRNOP
  1. K ^TMP("LR",$J),ZTREQ
  1. ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1. K HCRN ;IHS/ANMC/CLS 11/1/95 HRCN
  1. ;----- END IHS MODIFICATIONS
  1. Q
  1. ;
  1. LRAD S X=$P(^LRO(68,LRAA,0),"^",3),(Y,LRAD)=$S(X="Y":$E(Y,1,3)_"0000","M"[X:$E(Y,1,5)_"00","Q"[X:$E(Y,1,3)_"0000"+(($E(Y,4,5)-1)\3*300+100),1:Y) D D^LRU S LRH(0)=Y Q
  1. ;
  1. H W !,$C(7),"TO SORT IN SEQUENCE, STARTING FROM A CERTAIN NAME,",!?7,"TYPE THAT NAME" Q
  1. ;
  1. H1 W !,$C(7),"TO SORT ONLY UP TO A CERTAIN NAME,",!?7,"TYPE THAT NAME" Q
  1. L D:'$D(IOM) I K LR("%") S $P(LR("%"),"-",IOM-1)="-" Q
  1. L1 D:'$D(IOM) I K LR("%1") S $P(LR("%1"),"=",IOM-1)="=" Q
  1. I S IOP="HOME" D ^%ZIS Q
  1. S S (LR("Q"),LRQ)=0,LRQ(1)=$$INS Q
  1. INS() ;Set institution Name from ^XMB
  1. N Y
  1. S Y=$P($G(^DIC(4,+$P($G(^XMB(1,1,"XUS")),U,17),0)),U)
  1. Q Y
  1. INSN() ;Set primary institution number from ^XMB
  1. N Y
  1. S Y=+$P($G(^XMB(1,1,"XUS")),U,17)
  1. Q Y
  1. DUZ2 ;Allow user to change Division [DUZ(2)] value
  1. N Y,X,DIC,I
  1. I '$D(^VA(200,+$G(DUZ),0))#2 W !,"You are not a valid user.",!!,$C(7) Q
  1. I $S('$G(DUZ(2)):1,'$D(^DIC(4,DUZ(2),0))#2:1,1:0) D Q
  1. . W !?5,"You do not currently have a valid Division assigned.",!,"Log off the system and try again.",!!,$C(7)
  1. S X=0 F S X=$O(^VA(200,DUZ,2,X)) Q:X<1 S I=$G(I)+1
  1. I $G(I)'>1 W !,"You have only one Division Defined in the New Person file, change not possible.",!! Q
  1. K DIC S DIC="^VA(200,DUZ,2,",DIC(0)="AEMNQ"
  1. S DIC("S")="I $G(^DIC(4,+Y,99))"
  1. D ^DIC K DIC,DIC("S")
  1. I Y'>0 D Q
  1. .W !,$C(7),"Division Unchanged - Currently you are assigned to "
  1. .W $P($G(^DIC(4,DUZ(2),99)),U)_" "_$P($G(^DIC(4,DUZ(2),0)),U),!
  1. S DUZ(2)=+Y W !?5,"Division is now set to [ ",$P($G(^DIC(4,DUZ(2),99)),U)_" "_$P($G(^DIC(4,DUZ(2),0)),U)," ]",! Q