- 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 ;