BLRRLEVN ;cmi/anch/maw - BLR Reference Lab Non LEDI Manifest Build ; 12-Apr-2016 14:25 ; MAW
;;5.2;IHS LABORATORY;**1034,1036,1037,1039**;NOV 01, 1997;Build 38
;
Q
;
SHIPMAN(ORD,RE,SHP) ;-- get data needed for HL7 message and manifest
N LA7RT,AA,AD,AN,TEST,LDFN,IDT,SPEC,SAMP,ORDN,OA,ON,BLROI,ADA,ACC,AREA,URG,ODT,CDT,ORDP,AC
N LOC,OPI,FLG,PRT,RL
S PRT=0
S BLROI=$O(^BLRRLO("B",ORD,0))
S ADA=0 F S ADA=$O(^BLRRLO(BLROI,3,ADA)) Q:'ADA D
. S FLG=0
. S AC=$P($G(^BLRRLO(BLROI,3,ADA,0)),U) ;p1036
. S FLG=$P($G(^BLRRLO(BLROI,3,ADA,0)),U,2) ;p1036
. I '$G(RE) Q:$G(FLG) ;p1036 quit if already accessioned
. I '$G(RE) D SETFLG(BLROI,ADA) ;p1036 set the flag as accessioned
. S LA7RT=$Q(^LRO(68,"C",AC))
. S AA=$QS(LA7RT,4)
. S AD=$QS(LA7RT,5)
. S AN=$QS(LA7RT,6)
. S ACC=$G(^LRO(68,AA,1,AD,1,AN,.2))
. S ORDN=$Q(^LRO(69,"C",ORD))
. S OA=$QS(ORDN,4)
. S ON=$QS(ORDN,5)
. S ODT=$P($G(^LRO(69,OA,1,ON,0)),U,5)
. ;S CDT=+$G(^LRO(69,OA,1,ON,1))
. S CDT=+$G(^LRO(68,AA,1,AD,1,AN,3)) ;draw time p1036
. S ORDP=$$ORDP(OA,ON)
. S TEST=$$TEST(AA,AD,AN)
. S URG=$P(TEST,U,2)
. S TEST=$P(TEST,U)
. S LDFN=$P($G(^LRO(68,AA,1,AD,1,AN,0)),U)
. S IDT=$P($G(^LRO(68,AA,1,AD,1,AN,3)),U,5)
. S SPEC=$P($G(^LR(LDFN,"CH",IDT,0)),U,5)
. S SAMP=$$SAMP(AA,AD,AN,SPEC)
. ;S SAMP=$P($G(^LRO(69,OA,1,ON,0)),U,3)
. S LOC=$P($G(^LRO(69,OA,1,ON,0)),U,9)
. S OPI=+$P($G(^LRO(69,OA,1,ON,0)),U,6)
. S AREA=$P($G(^LAB(60,TEST,8,$S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)),U,2)
. S RL=$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U)
. Q:'$$NOMAP^BLRRLEVT(RL,TEST,LOC) ;p1036 dont ship or print a non mapped test
. D BLRVARS(BLROI,ORD,AC,ACC,CDT,TEST,SAMP,SPEC,ORDP,AREA,URG,ODT,LOC,OPI)
. I '$G(RE) S X="BLR REFLAB ACCESSION A TEST",DIC=101 D EN^XQOR
. I $G(RE),$G(SHP) S X="BLR REFLAB ACCESSION A TEST",DIC=101 D EN^XQOR
. S PRT=1
. Q
;ihs/cmi/maw 04/10/2016 ask for # of copies
S COPI=$$GETCOP(DUZ(2))
I $G(COPI) S COP=$$ASKCOP(COPI)
I $G(PRT) D
. W !,"Printing Shipping Manifests for Reference Lab..."
. W !,"Printing manifest for order # "_ORD
. D PRT^BLRSHPM(RE,$S($G(COP):COP,1:1))
D KVAR
Q
;
GETCOP(DZ2) ;-- get number of copies
N COPI
S COPI=$P($G(^BLRSITE(DZ2,"RLA")),U,5)
Q COPI
;
ASKCOP(CP) ;-- ask the number of copies
S DIR(0)="N^1:9",DIR("A")="How many of copies of the shipping manifest: "
S DIR("B")=CP
D ^DIR
K DIR
I $D(DIRUT) Q 1
I $G(Y)>1 Q Y
Q 1
;
BLRVARS(OI,OR,UID,ACC,CD,TS,SM,SP,OP,AR,UG,OD,LC,PI) ; Setup the variables for manifest and message
;set all BLR VARS call TMPSET before manifest
K BLRRL,BLRRLC
S BLRRL("PAT")=$P($G(^BLRRLO(OI,0)),U,4) ;patient
S BLRRL("ACC")=ACC ;accession number
S BLRRL("UID")=UID ;unique id
I $G(BLROPT)="ADDCOL" S LRUID=UID ;LRUID doens't get reset correctly on collection list
S BLRRL("CDT")=CD ;collection date
S BLRRL("LRTS")=TS ;test
S BLRRL("ORDP")=OP ;ordering provider
S BLRRL("SAMP")=SM ;collection sample
I SP S BLRRL("SRC")=$P($G(^LAB(61,SP,0)),U) ;specimen
S BLRRL("RL")=+$G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")) ;ref lab site
S BLRRL("RLE")=$P($G(^BLRRL(BLRRL("RL"),0)),U) ;external name
S BLRRL("TNAME")=$P($G(^LAB(60,TS,0)),U) ;get test name
S BLRRL("ABBR")=$P($G(^LRO(68,AR,0)),U,11) ;get area abbr
S BLRRL("TST")=TS ;get test ien
S BLRRL("TCODEE")=$$CODE^BLRRLEVT(BLRRL("RL"),TEST) ;lookup test code
S BLRRL("TCODE")=$P(BLRRL("TCODEE"),U) ;test code
S BLRRL("SHIPCOND")=$P(BLRRL("TCODEE"),U,2) ;shipping condition
S BLRRL("TCNM")=BLRRL("TCODE")_U_BLRRL("TNAME") ;test arry
I $G(BLRRL("RLE"))="LABCORP" D
. S BLRRL("TCNM")=BLRRL("TCNM")_"^L"
S BLRRL("URGHL")=$S($G(UG):$P($G(^LAB(62.05,UG,0)),U,4),1:"") ;urgency
S BLRRL("URG")=UG ;urgency
S BLRRL("ODT")=OD ;order date
S BLRRL("ORD")=OR ;order
S BLRRL("LOC")=$$GET1^DIQ(44,LC,.01) ;ordering location
S BLRRL("CLIENT")=$P($G(^BLRRLO(OI,0)),U,3)
S BLRRL("BILL TYPE")=$$GET1^DIQ(9009026.3,OI,.05)
S BLRRL("ORDPNM")=$$GET1^DIQ(200,PI,.01)
S BLRRL("ORDPNPI")=$$GET1^DIQ(200,PI,41.99)
S BLRRL("ORDPUPIN")=$$GET1^DIQ(200,PI,9999999.08)
S (BLRTS,BLRTSTDA)=TS
D ADDDX^BLRRLHL2(OR)
I $E($G(BLRRL("BILL TYPE")),1,1)="T" D
. S PAT=BLRRL("PAT")
. S LRORD=OR
. S LRUID=UID
. D INS^BLRRLHL(BLRRL("PAT"),1)
. K PAT ;,LRORD,LRUID
I $E($G(BLRRL("BILL TYPE")),1,1)="P" D ;cmi/maw p1039
. D PATBILL^BLRRLHL(TS)
N BDA,BLRCM,RSC,QS,RS,AOD
S BDA=0 F S BDA=$O(BLRRL(BDA)) Q:BDA="" D
. S BLRRL(TS,BDA)=$G(BLRRL(BDA))
S BLRCM=0 F S BLRCM=$O(^BLRRLO(OI,4,BLRCM)) Q:'BLRCM D
. Q:$P(^BLRRLO(OI,4,BLRCM,0),U)'=TS
. S AOD=$G(^BLRRLO(OI,4,BLRCM,0))
. S RSC=$P(AOD,U,5)
. S QS=$P(AOD,U,3)
. S RS=$P(AOD,U,4)
. S BLRRL(TS,"COMMENT",BLRCM)=RSC_U_QS_U_RS
. S BLRRL("COMMENT",BLRCM)=RSC_U_QS_U_RS
D TMPSET^BLRRLEVT(.BLRRL)
Q
;
SAMP(A,D,N,SPC) ;-- get collection sample
N SAM,SDA
S SAM=""
S SDA=0 F S SDA=$O(^LRO(68,A,1,D,1,N,5,SDA)) Q:'SDA!($G(SAM)) D
. ;I $P($G(^LRO(68,A,1,D,1,N,5,SDA,0)),U)=SPC D Q
. S SAM=$P($G(^LRO(68,A,1,D,1,N,5,SDA,0)),U,2)
Q SAM
;
TEST(A,D,N) ;-- get the test based on acc passed in
N TDA,TST
S TST=""
S TDA=0 F S TDA=$O(^LRO(68,A,1,D,1,N,4,TDA)) Q:'TDA D
. S TST=+$G(^LRO(68,A,1,D,1,N,4,TDA,0))
. S URG=$P($G(^LRO(68,A,1,D,1,N,4,TDA,0)),U,2)
Q TST_U_URG
;
ORDP(OA,ON) ;-- get the ordering provider based on order number
N PRV,PRVI,PRVE,NPI,UPIN,PTYP
S PTYP=$S($P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,19)="N":"N",1:"U")
S PRVI=+$P($G(^LRO(69,OA,1,ON,0)),U,6)
S PRVE=$$VAL^XBDIQ1(200,PRVI,.01)
S UPIN=$$VAL^XBDIQ1(200,PRVI,9999999.08)
S NPI=$$VAL^XBDIQ1(200,PRVI,41.99) ;cmi/maw 2/26/2008 NPI
S PRVE=$P(PRVE,",")_"^"_$P($P(PRVE,",",2)," ")
S PRV=$S(PTYP="N":NPI,1:UPIN)_"^"_PRVE
S $P(PRV,U,8)=PTYP
Q PRV
;
KVAR ;-- kill off remaining variables not needed
K AGINS,AGINSN1,AGINSNN,BLRINSS,BLRRDA,BLRTS,BLRTSTDA,DFN,INSCNT,INSGEND,DOB,SEX
K BLRRL,INA
K ^TMP("BLRRL",$J)
Q
;
PRTLC(ORD,ACC,DF,LOC,ODT,PRV,TST) ;-- printout the lab collect information
N NM,CHT,RLOC,ORDT,PRVE,TSTE,ICD,ICDE,OI,RDX
S OI=$O(^BLRRLO("ACC",ACC,0))
S NM=$$GET1^DIQ(2,DF,.01)
S CHT=$$HRN^AUPNPAT(DF,DUZ(2))
S RLOC=LOC
S ORDT=$$FMTE^XLFDT(ODT)
S PRVE=$$GET1^DIQ(200,PRV,.01)
S TSTE=$$GET1^DIQ(60,TST,.01)
S ICD=$O(^BLRRLO(OI,1,"B",0))
S RDX=""
I $D(^ICDS(0)),ICD]"" S RDX=$$ICDDX^ICDEX(ICD,DT)
I '$D(^ICDS(0)),ICD]"" S RDX=$$ICDDX^ICDCODE(ICD,DT)
S ICDE=$P(RDX,U,2)_"-"_$P(RDX,U,4)
U IO
W !!,"Information for this accession:"
W !,NM,?35,CHT,?50,"Requesting Loc: "_RLOC
W !,"Date Ordered: "_ORDT,?50,"UID: "_ACC
W !,"Lab Order # "_ORD,?40,"Provider: "_PRVE
W !,?3,TSTE
W !,?10,"DX: "_ICDE
W !!
Q
;
IMP(D) ;PEP - which coding system should be used:
;RETURN IEN of entry in ^ICDS
;1 = ICD9
;30 = ICD10
;will need to add subroutines for ICD11 when we have that.
I $G(D)="" S D=DT
NEW X,Y,Z
I '$O(^ICDS("F",80,0)) Q 1
S Y=""
S X=0 F S X=$O(^ICDS("F",80,X)) Q:X'=+X D
.I $P(^ICDS(X,0),U,4)="" Q ;NO IMPLEMENTATION DATE?? SKIP IT
.S Z($P(^ICDS(X,0),U,4))=X
;now go through and get the last one before it imp date is greater than the visit date
S X=0 F S X=$O(Z(X)) Q:X="" D
.I D<X Q
.I D=X S Y=Z(X) Q
.I D>X S Y=Z(X) Q
I Y="" S Y=$O(Z(0)) Q Z(Y)
Q Y
;
SETFLG(OI,AD) ;-- set the flag as accessioned
N FDA,FIENS,FERR
S FIENS=AD_","_OI_","
S FDA(9009026.33,FIENS,.02)=1
D FILE^DIE("K","FDA","FERR(1)")
I $D(FERR(1)),$G(LRQUIET) D
. W !,"Error setting accession flag in the BLR REFERENCE LAB ORDER/ACCESSION file"
Q
;
RESHIP ;-- reship a non ledi order
N RORD,RESHIP
S RORD=$$WORD
Q:'$G(RORD)
I '$O(^BLRRLO("B",RORD,0)) W !,"Order Number does not exist" Q
S RESHIP=$$RSHPYN()
W !,$S($G(RESHIP):"Reshipping order: "_RORD,1:"Reprinting Order: "_RORD)
D SHIPMAN(RORD,1,RESHIP)
Q
;
RSHPYN() ;-- ask whether to reship
W !
S DIR(0)="Y",DIR("A")="Would you like to reship this order as well"
D ^DIR
Q:$D(DIRUT) 0
K DIR
I Y<0 Q 0
Q +$G(Y)
;
WORD() ;-- reship which order
S DIR(0)="N",DIR("A")="Enter Order Number"
D ^DIR
K DIR
Q:$D(DIRUT) 0
I Y<0 Q 0
Q +$G(Y)
;
BLRRLEVN ;cmi/anch/maw - BLR Reference Lab Non LEDI Manifest Build ; 12-Apr-2016 14:25 ; MAW
+1 ;;5.2;IHS LABORATORY;**1034,1036,1037,1039**;NOV 01, 1997;Build 38
+2 ;
+3 QUIT
+4 ;
SHIPMAN(ORD,RE,SHP) ;-- get data needed for HL7 message and manifest
+1 NEW LA7RT,AA,AD,AN,TEST,LDFN,IDT,SPEC,SAMP,ORDN,OA,ON,BLROI,ADA,ACC,AREA,URG,ODT,CDT,ORDP,AC
+2 NEW LOC,OPI,FLG,PRT,RL
+3 SET PRT=0
+4 SET BLROI=$ORDER(^BLRRLO("B",ORD,0))
+5 SET ADA=0
FOR
SET ADA=$ORDER(^BLRRLO(BLROI,3,ADA))
IF 'ADA
QUIT
Begin DoDot:1
+6 SET FLG=0
+7 ;p1036
SET AC=$PIECE($GET(^BLRRLO(BLROI,3,ADA,0)),U)
+8 ;p1036
SET FLG=$PIECE($GET(^BLRRLO(BLROI,3,ADA,0)),U,2)
+9 ;p1036 quit if already accessioned
IF '$GET(RE)
IF $GET(FLG)
QUIT
+10 ;p1036 set the flag as accessioned
IF '$GET(RE)
DO SETFLG(BLROI,ADA)
+11 SET LA7RT=$QUERY(^LRO(68,"C",AC))
+12 SET AA=$QSUBSCRIPT(LA7RT,4)
+13 SET AD=$QSUBSCRIPT(LA7RT,5)
+14 SET AN=$QSUBSCRIPT(LA7RT,6)
+15 SET ACC=$GET(^LRO(68,AA,1,AD,1,AN,.2))
+16 SET ORDN=$QUERY(^LRO(69,"C",ORD))
+17 SET OA=$QSUBSCRIPT(ORDN,4)
+18 SET ON=$QSUBSCRIPT(ORDN,5)
+19 SET ODT=$PIECE($GET(^LRO(69,OA,1,ON,0)),U,5)
+20 ;S CDT=+$G(^LRO(69,OA,1,ON,1))
+21 ;draw time p1036
SET CDT=+$GET(^LRO(68,AA,1,AD,1,AN,3))
+22 SET ORDP=$$ORDP(OA,ON)
+23 SET TEST=$$TEST(AA,AD,AN)
+24 SET URG=$PIECE(TEST,U,2)
+25 SET TEST=$PIECE(TEST,U)
+26 SET LDFN=$PIECE($GET(^LRO(68,AA,1,AD,1,AN,0)),U)
+27 SET IDT=$PIECE($GET(^LRO(68,AA,1,AD,1,AN,3)),U,5)
+28 SET SPEC=$PIECE($GET(^LR(LDFN,"CH",IDT,0)),U,5)
+29 SET SAMP=$$SAMP(AA,AD,AN,SPEC)
+30 ;S SAMP=$P($G(^LRO(69,OA,1,ON,0)),U,3)
+31 SET LOC=$PIECE($GET(^LRO(69,OA,1,ON,0)),U,9)
+32 SET OPI=+$PIECE($GET(^LRO(69,OA,1,ON,0)),U,6)
+33 SET AREA=$PIECE($GET(^LAB(60,TEST,8,$SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),0)),U,2)
+34 SET RL=$PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U)
+35 ;p1036 dont ship or print a non mapped test
IF '$$NOMAP^BLRRLEVT(RL,TEST,LOC)
QUIT
+36 DO BLRVARS(BLROI,ORD,AC,ACC,CDT,TEST,SAMP,SPEC,ORDP,AREA,URG,ODT,LOC,OPI)
+37 IF '$GET(RE)
SET X="BLR REFLAB ACCESSION A TEST"
SET DIC=101
DO EN^XQOR
+38 IF $GET(RE)
IF $GET(SHP)
SET X="BLR REFLAB ACCESSION A TEST"
SET DIC=101
DO EN^XQOR
+39 SET PRT=1
+40 QUIT
End DoDot:1
+41 ;ihs/cmi/maw 04/10/2016 ask for # of copies
+42 SET COPI=$$GETCOP(DUZ(2))
+43 IF $GET(COPI)
SET COP=$$ASKCOP(COPI)
+44 IF $GET(PRT)
Begin DoDot:1
+45 WRITE !,"Printing Shipping Manifests for Reference Lab..."
+46 WRITE !,"Printing manifest for order # "_ORD
+47 DO PRT^BLRSHPM(RE,$SELECT($GET(COP):COP,1:1))
End DoDot:1
+48 DO KVAR
+49 QUIT
+50 ;
GETCOP(DZ2) ;-- get number of copies
+1 NEW COPI
+2 SET COPI=$PIECE($GET(^BLRSITE(DZ2,"RLA")),U,5)
+3 QUIT COPI
+4 ;
ASKCOP(CP) ;-- ask the number of copies
+1 SET DIR(0)="N^1:9"
SET DIR("A")="How many of copies of the shipping manifest: "
+2 SET DIR("B")=CP
+3 DO ^DIR
+4 KILL DIR
+5 IF $DATA(DIRUT)
QUIT 1
+6 IF $GET(Y)>1
QUIT Y
+7 QUIT 1
+8 ;
BLRVARS(OI,OR,UID,ACC,CD,TS,SM,SP,OP,AR,UG,OD,LC,PI) ; Setup the variables for manifest and message
+1 ;set all BLR VARS call TMPSET before manifest
+2 KILL BLRRL,BLRRLC
+3 ;patient
SET BLRRL("PAT")=$PIECE($GET(^BLRRLO(OI,0)),U,4)
+4 ;accession number
SET BLRRL("ACC")=ACC
+5 ;unique id
SET BLRRL("UID")=UID
+6 ;LRUID doens't get reset correctly on collection list
IF $GET(BLROPT)="ADDCOL"
SET LRUID=UID
+7 ;collection date
SET BLRRL("CDT")=CD
+8 ;test
SET BLRRL("LRTS")=TS
+9 ;ordering provider
SET BLRRL("ORDP")=OP
+10 ;collection sample
SET BLRRL("SAMP")=SM
+11 ;specimen
IF SP
SET BLRRL("SRC")=$PIECE($GET(^LAB(61,SP,0)),U)
+12 ;ref lab site
SET BLRRL("RL")=+$GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL"))
+13 ;external name
SET BLRRL("RLE")=$PIECE($GET(^BLRRL(BLRRL("RL"),0)),U)
+14 ;get test name
SET BLRRL("TNAME")=$PIECE($GET(^LAB(60,TS,0)),U)
+15 ;get area abbr
SET BLRRL("ABBR")=$PIECE($GET(^LRO(68,AR,0)),U,11)
+16 ;get test ien
SET BLRRL("TST")=TS
+17 ;lookup test code
SET BLRRL("TCODEE")=$$CODE^BLRRLEVT(BLRRL("RL"),TEST)
+18 ;test code
SET BLRRL("TCODE")=$PIECE(BLRRL("TCODEE"),U)
+19 ;shipping condition
SET BLRRL("SHIPCOND")=$PIECE(BLRRL("TCODEE"),U,2)
+20 ;test arry
SET BLRRL("TCNM")=BLRRL("TCODE")_U_BLRRL("TNAME")
+21 IF $GET(BLRRL("RLE"))="LABCORP"
Begin DoDot:1
+22 SET BLRRL("TCNM")=BLRRL("TCNM")_"^L"
End DoDot:1
+23 ;urgency
SET BLRRL("URGHL")=$SELECT($GET(UG):$PIECE($GET(^LAB(62.05,UG,0)),U,4),1:"")
+24 ;urgency
SET BLRRL("URG")=UG
+25 ;order date
SET BLRRL("ODT")=OD
+26 ;order
SET BLRRL("ORD")=OR
+27 ;ordering location
SET BLRRL("LOC")=$$GET1^DIQ(44,LC,.01)
+28 SET BLRRL("CLIENT")=$PIECE($GET(^BLRRLO(OI,0)),U,3)
+29 SET BLRRL("BILL TYPE")=$$GET1^DIQ(9009026.3,OI,.05)
+30 SET BLRRL("ORDPNM")=$$GET1^DIQ(200,PI,.01)
+31 SET BLRRL("ORDPNPI")=$$GET1^DIQ(200,PI,41.99)
+32 SET BLRRL("ORDPUPIN")=$$GET1^DIQ(200,PI,9999999.08)
+33 SET (BLRTS,BLRTSTDA)=TS
+34 DO ADDDX^BLRRLHL2(OR)
+35 IF $EXTRACT($GET(BLRRL("BILL TYPE")),1,1)="T"
Begin DoDot:1
+36 SET PAT=BLRRL("PAT")
+37 SET LRORD=OR
+38 SET LRUID=UID
+39 DO INS^BLRRLHL(BLRRL("PAT"),1)
+40 ;,LRORD,LRUID
KILL PAT
End DoDot:1
+41 ;cmi/maw p1039
IF $EXTRACT($GET(BLRRL("BILL TYPE")),1,1)="P"
Begin DoDot:1
+42 DO PATBILL^BLRRLHL(TS)
End DoDot:1
+43 NEW BDA,BLRCM,RSC,QS,RS,AOD
+44 SET BDA=0
FOR
SET BDA=$ORDER(BLRRL(BDA))
IF BDA=""
QUIT
Begin DoDot:1
+45 SET BLRRL(TS,BDA)=$GET(BLRRL(BDA))
End DoDot:1
+46 SET BLRCM=0
FOR
SET BLRCM=$ORDER(^BLRRLO(OI,4,BLRCM))
IF 'BLRCM
QUIT
Begin DoDot:1
+47 IF $PIECE(^BLRRLO(OI,4,BLRCM,0),U)'=TS
QUIT
+48 SET AOD=$GET(^BLRRLO(OI,4,BLRCM,0))
+49 SET RSC=$PIECE(AOD,U,5)
+50 SET QS=$PIECE(AOD,U,3)
+51 SET RS=$PIECE(AOD,U,4)
+52 SET BLRRL(TS,"COMMENT",BLRCM)=RSC_U_QS_U_RS
+53 SET BLRRL("COMMENT",BLRCM)=RSC_U_QS_U_RS
End DoDot:1
+54 DO TMPSET^BLRRLEVT(.BLRRL)
+55 QUIT
+56 ;
SAMP(A,D,N,SPC) ;-- get collection sample
+1 NEW SAM,SDA
+2 SET SAM=""
+3 SET SDA=0
FOR
SET SDA=$ORDER(^LRO(68,A,1,D,1,N,5,SDA))
IF 'SDA!($GET(SAM))
QUIT
Begin DoDot:1
+4 ;I $P($G(^LRO(68,A,1,D,1,N,5,SDA,0)),U)=SPC D Q
+5 SET SAM=$PIECE($GET(^LRO(68,A,1,D,1,N,5,SDA,0)),U,2)
End DoDot:1
+6 QUIT SAM
+7 ;
TEST(A,D,N) ;-- get the test based on acc passed in
+1 NEW TDA,TST
+2 SET TST=""
+3 SET TDA=0
FOR
SET TDA=$ORDER(^LRO(68,A,1,D,1,N,4,TDA))
IF 'TDA
QUIT
Begin DoDot:1
+4 SET TST=+$GET(^LRO(68,A,1,D,1,N,4,TDA,0))
+5 SET URG=$PIECE($GET(^LRO(68,A,1,D,1,N,4,TDA,0)),U,2)
End DoDot:1
+6 QUIT TST_U_URG
+7 ;
ORDP(OA,ON) ;-- get the ordering provider based on order number
+1 NEW PRV,PRVI,PRVE,NPI,UPIN,PTYP
+2 SET PTYP=$SELECT($PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,19)="N":"N",1:"U")
+3 SET PRVI=+$PIECE($GET(^LRO(69,OA,1,ON,0)),U,6)
+4 SET PRVE=$$VAL^XBDIQ1(200,PRVI,.01)
+5 SET UPIN=$$VAL^XBDIQ1(200,PRVI,9999999.08)
+6 ;cmi/maw 2/26/2008 NPI
SET NPI=$$VAL^XBDIQ1(200,PRVI,41.99)
+7 SET PRVE=$PIECE(PRVE,",")_"^"_$PIECE($PIECE(PRVE,",",2)," ")
+8 SET PRV=$SELECT(PTYP="N":NPI,1:UPIN)_"^"_PRVE
+9 SET $PIECE(PRV,U,8)=PTYP
+10 QUIT PRV
+11 ;
KVAR ;-- kill off remaining variables not needed
+1 KILL AGINS,AGINSN1,AGINSNN,BLRINSS,BLRRDA,BLRTS,BLRTSTDA,DFN,INSCNT,INSGEND,DOB,SEX
+2 KILL BLRRL,INA
+3 KILL ^TMP("BLRRL",$JOB)
+4 QUIT
+5 ;
PRTLC(ORD,ACC,DF,LOC,ODT,PRV,TST) ;-- printout the lab collect information
+1 NEW NM,CHT,RLOC,ORDT,PRVE,TSTE,ICD,ICDE,OI,RDX
+2 SET OI=$ORDER(^BLRRLO("ACC",ACC,0))
+3 SET NM=$$GET1^DIQ(2,DF,.01)
+4 SET CHT=$$HRN^AUPNPAT(DF,DUZ(2))
+5 SET RLOC=LOC
+6 SET ORDT=$$FMTE^XLFDT(ODT)
+7 SET PRVE=$$GET1^DIQ(200,PRV,.01)
+8 SET TSTE=$$GET1^DIQ(60,TST,.01)
+9 SET ICD=$ORDER(^BLRRLO(OI,1,"B",0))
+10 SET RDX=""
+11 IF $DATA(^ICDS(0))
IF ICD]""
SET RDX=$$ICDDX^ICDEX(ICD,DT)
+12 IF '$DATA(^ICDS(0))
IF ICD]""
SET RDX=$$ICDDX^ICDCODE(ICD,DT)
+13 SET ICDE=$PIECE(RDX,U,2)_"-"_$PIECE(RDX,U,4)
+14 USE IO
+15 WRITE !!,"Information for this accession:"
+16 WRITE !,NM,?35,CHT,?50,"Requesting Loc: "_RLOC
+17 WRITE !,"Date Ordered: "_ORDT,?50,"UID: "_ACC
+18 WRITE !,"Lab Order # "_ORD,?40,"Provider: "_PRVE
+19 WRITE !,?3,TSTE
+20 WRITE !,?10,"DX: "_ICDE
+21 WRITE !!
+22 QUIT
+23 ;
IMP(D) ;PEP - which coding system should be used:
+1 ;RETURN IEN of entry in ^ICDS
+2 ;1 = ICD9
+3 ;30 = ICD10
+4 ;will need to add subroutines for ICD11 when we have that.
+5 IF $GET(D)=""
SET D=DT
+6 NEW X,Y,Z
+7 IF '$ORDER(^ICDS("F",80,0))
QUIT 1
+8 SET Y=""
+9 SET X=0
FOR
SET X=$ORDER(^ICDS("F",80,X))
IF X'=+X
QUIT
Begin DoDot:1
+10 ;NO IMPLEMENTATION DATE?? SKIP IT
IF $PIECE(^ICDS(X,0),U,4)=""
QUIT
+11 SET Z($PIECE(^ICDS(X,0),U,4))=X
End DoDot:1
+12 ;now go through and get the last one before it imp date is greater than the visit date
+13 SET X=0
FOR
SET X=$ORDER(Z(X))
IF X=""
QUIT
Begin DoDot:1
+14 IF D<X
QUIT
+15 IF D=X
SET Y=Z(X)
QUIT
+16 IF D>X
SET Y=Z(X)
QUIT
End DoDot:1
+17 IF Y=""
SET Y=$ORDER(Z(0))
QUIT Z(Y)
+18 QUIT Y
+19 ;
SETFLG(OI,AD) ;-- set the flag as accessioned
+1 NEW FDA,FIENS,FERR
+2 SET FIENS=AD_","_OI_","
+3 SET FDA(9009026.33,FIENS,.02)=1
+4 DO FILE^DIE("K","FDA","FERR(1)")
+5 IF $DATA(FERR(1))
IF $GET(LRQUIET)
Begin DoDot:1
+6 WRITE !,"Error setting accession flag in the BLR REFERENCE LAB ORDER/ACCESSION file"
End DoDot:1
+7 QUIT
+8 ;
RESHIP ;-- reship a non ledi order
+1 NEW RORD,RESHIP
+2 SET RORD=$$WORD
+3 IF '$GET(RORD)
QUIT
+4 IF '$ORDER(^BLRRLO("B",RORD,0))
WRITE !,"Order Number does not exist"
QUIT
+5 SET RESHIP=$$RSHPYN()
+6 WRITE !,$SELECT($GET(RESHIP):"Reshipping order: "_RORD,1:"Reprinting Order: "_RORD)
+7 DO SHIPMAN(RORD,1,RESHIP)
+8 QUIT
+9 ;
RSHPYN() ;-- ask whether to reship
+1 WRITE !
+2 SET DIR(0)="Y"
SET DIR("A")="Would you like to reship this order as well"
+3 DO ^DIR
+4 IF $DATA(DIRUT)
QUIT 0
+5 KILL DIR
+6 IF Y<0
QUIT 0
+7 QUIT +$GET(Y)
+8 ;
WORD() ;-- reship which order
+1 SET DIR(0)="N"
SET DIR("A")="Enter Order Number"
+2 DO ^DIR
+3 KILL DIR
+4 IF $DATA(DIRUT)
QUIT 0
+5 IF Y<0
QUIT 0
+6 QUIT +$GET(Y)
+7 ;
