- ONCOLRU ;Hines OIFO/GWB - LAB UTILITY ;8/21/93
- ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
- ;
- D S %=$E(Y,4,5)*3
- S Y=$E("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",%-2,%)_" "_$S($E(Y,6,7):$J(+$E(Y,6,7),2)_", ",1:"")_($E(Y,1,3)+1700)_$S(Y[".":" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"")
- S:Y[1700 Y=""
- Q
- ;
- SSN S SSN(2)=SSN
- 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
- 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),1:"????") S:'$L(SSN) SSN="?" Q
- ;
- B ;Start Date/Go to Date
- S Y=$P(^ONCO(160.1,OSP,0),U,5)
- I Y="" S Y=DT
- S Y=$E(Y,4,5)_"-"_$E(Y,6,7)_"-"_($E(Y,1,3)+1700)
- S %DT="AEX",%DT(0)="-"_DT,%DT("A")="Start Date: ",%DT("B")=Y
- D ^%DT K %DT
- Q:Y<1 S LRSDT=Y
- S %DT="AEX",%DT(0)="-"_DT,%DT("A")="Go to Date: ",%DT("B")="TODAY"
- D ^%DT K %DT
- Q:Y<1 S LRLDT=Y I LRSDT>LRLDT S X=LRSDT,LRSDT=LRLDT,LRLDT=X
- S $P(^ONCO(160.1,OSP,0),U,5)=LRLDT
- S Y=LRSDT D D S LRSTR=Y,Y=LRLDT D D S LRLST=Y Q
- ;
- ;
- V K A,B,C,D,DEF,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
- K AGE,DOB,PNM,POP,SEX
- K DIC,DIE,DR,DFN,DIWF,D0,DQ,DA,DX,DE,DG
- K %Y,%X
- K ZTSK,ZTRTN,ZTSAVE,ZTDESC
- K LRWHO,LRSDT,LRLDT,LRSTR,LRLST,LRXR,LRXREF,LRADM,LRADX,LRABV,LRAWRD
- K LRAX,LRAD,LRDPAF,LRFNAM,LRMD,LRPF,LRPFN,LRSVC,LRID,LRAP,LRSAV,LREP
- K LRDTI,LRODT,LRSN,LRBL,LRCPT,LRFND,LRPPT,LRIDT,LRPMD,LRRMD,LR,LRA,LRB
- K LRC,LRD,LRE,LRF,LRG,LRH,LRI,LRJ,LRK,LRL,LRM,LRN,LRO,LRP,LRQ,LRR,LRS
- K LRT,LRU,LRV,LRW,LRX,LRY,LRZ,LRAU,LRFLN,LRLIDT,LRND,LRST,LRTK,LRWW
- K LRAC,DIWL,DIWR,DIWF,LROLLOC,LRCAPLOC,LRDFN,LRSF,LR,LRAN,LRAA,LRSOP
- K LROPT,LRRH,SSN,LRLLOC,LRDPF,LREND,LREXP,LRTOD,LRABO,LRPABO,LRPRH,LRSS
- K LRCS,LRRC,LRSIT,LRWHN,LRSA,LRIFN,LRBLT
- K ^TMP($J),^TMP("LRBL",$J)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOLRU 1902 printed Feb 18, 2025@23:51:40 Page 2
- ONCOLRU ;Hines OIFO/GWB - LAB UTILITY ;8/21/93
- +1 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
- +2 ;
- D SET %=$EXTRACT(Y,4,5)*3
- +1 SET Y=$EXTRACT("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",%-2,%)_" "_$SELECT($EXTRACT(Y,6,7):$JUSTIFY(+$EXTRACT(Y,6,7),2)_", ",1:"")_($EXTRACT(Y,1,3)+1700)_$SELECT(Y[".":" "_$EXTRACT(Y_0,9,10)_":"_$EXTRACT(Y_"000",11,12),1:"")
- +2 if Y[1700
- SET Y=""
- +3 QUIT
- +4 ;
- SSN SET SSN(2)=SSN
- +1 IF $LENGTH(DUZ("AG"))
- IF "NAFARMY"[DUZ("AG")
- SET SSN=$SELECT($LENGTH(SSN)<11:$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,10),1:$EXTRACT(SSN,10,11)_"/"_$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9))
- SET SSN(1)=$SELECT($PIECE(SSN,"-",3):$PIECE(SSN,"-",3),1:$EXTRACT(SSN,9,12))
- QUIT
- +2 if $LENGTH(SSN)>8
- SET SSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,99)
- +3 SET SSN(1)=$SELECT($PIECE(SSN,"-",3):$PIECE(SSN,"-",3),1:"????")
- if '$LENGTH(SSN)
- SET SSN="?"
- QUIT
- +4 ;
- B ;Start Date/Go to Date
- +1 SET Y=$PIECE(^ONCO(160.1,OSP,0),U,5)
- +2 IF Y=""
- SET Y=DT
- +3 SET Y=$EXTRACT(Y,4,5)_"-"_$EXTRACT(Y,6,7)_"-"_($EXTRACT(Y,1,3)+1700)
- +4 SET %DT="AEX"
- SET %DT(0)="-"_DT
- SET %DT("A")="Start Date: "
- SET %DT("B")=Y
- +5 DO ^%DT
- KILL %DT
- +6 if Y<1
- QUIT
- SET LRSDT=Y
- +7 SET %DT="AEX"
- SET %DT(0)="-"_DT
- SET %DT("A")="Go to Date: "
- SET %DT("B")="TODAY"
- +8 DO ^%DT
- KILL %DT
- +9 if Y<1
- QUIT
- SET LRLDT=Y
- IF LRSDT>LRLDT
- SET X=LRSDT
- SET LRSDT=LRLDT
- SET LRLDT=X
- +10 SET $PIECE(^ONCO(160.1,OSP,0),U,5)=LRLDT
- +11 SET Y=LRSDT
- DO D
- SET LRSTR=Y
- SET Y=LRLDT
- DO D
- SET LRLST=Y
- QUIT
- +12 ;
- +13 ;
- V KILL A,B,C,D,DEF,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
- +1 KILL AGE,DOB,PNM,POP,SEX
- +2 KILL DIC,DIE,DR,DFN,DIWF,D0,DQ,DA,DX,DE,DG
- +3 KILL %Y,%X
- +4 KILL ZTSK,ZTRTN,ZTSAVE,ZTDESC
- +5 KILL LRWHO,LRSDT,LRLDT,LRSTR,LRLST,LRXR,LRXREF,LRADM,LRADX,LRABV,LRAWRD
- +6 KILL LRAX,LRAD,LRDPAF,LRFNAM,LRMD,LRPF,LRPFN,LRSVC,LRID,LRAP,LRSAV,LREP
- +7 KILL LRDTI,LRODT,LRSN,LRBL,LRCPT,LRFND,LRPPT,LRIDT,LRPMD,LRRMD,LR,LRA,LRB
- +8 KILL LRC,LRD,LRE,LRF,LRG,LRH,LRI,LRJ,LRK,LRL,LRM,LRN,LRO,LRP,LRQ,LRR,LRS
- +9 KILL LRT,LRU,LRV,LRW,LRX,LRY,LRZ,LRAU,LRFLN,LRLIDT,LRND,LRST,LRTK,LRWW
- +10 KILL LRAC,DIWL,DIWR,DIWF,LROLLOC,LRCAPLOC,LRDFN,LRSF,LR,LRAN,LRAA,LRSOP
- +11 KILL LROPT,LRRH,SSN,LRLLOC,LRDPF,LREND,LREXP,LRTOD,LRABO,LRPABO,LRPRH,LRSS
- +12 KILL LRCS,LRRC,LRSIT,LRWHN,LRSA,LRIFN,LRBLT
- +13 KILL ^TMP($JOB),^TMP("LRBL",$JOB)
- +14 QUIT