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

BLRRLEVN.m

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