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

CIAZPLBB.m

Go to the documentation of this file. 
  1. CIAZPLBB ;CIA/PLS - PCC Hook for Lab- Blood Bank data ;07-Sep-2004 19:36;DKM
  1.  ;;1.1;VUECENTRIC RPMS SUPPORT;;Sep 14, 2004
  1.  ;;Copyright 2000-2004, Clinical Informatics Associates, Inc.
  1.  ;=================================================================
  1. EN(DATA) N MSG
  1.  I $D(DATA)=1 M MSG=@DATA
  1.  E  M MSG=DATA
  1.  ;D LOG(.MSG)
  1.  ;check for PCC capture
  1.  ;I $$QUEUE^CIAUTSK("TASK^CIAZPLBB","PCC VLAB FILER",,"MSG(")
  1.  D TASK
  1.  Q
  1.  ; Log data
  1. LOG(ARY,NMSP) ;
  1.  S NMSP="CIAZPLBB"_$S($G(NMSP)="":"",1:"."_NMSP)
  1.  L +^XTMP(NMSP):2
  1.  M ^($O(^XTMP(NMSP,""),-1)+1)=ARY
  1.  L -^XTMP(NMSP)
  1.  Q
  1. TASK N SEG,LP,DL1,DL2,OIEN,ORD,ACC,STATUS,DFN,DAT,LOC,ERR,PCC,VSIT
  1.  N CAT,CONTROL,LABORD,PRV,ODT,CDT,VLAB,SPEC,VSTAT,CPTP,CPTCODE
  1.  N DAT,ACT,LOINC,DIAG,LODT,LSEQ
  1.  S LP=0
  1.  S SEG=$$SEG("MSH",.LP)
  1.  Q:'LP
  1.  S DL1=$E(SEG,4),DL2=$E(SEG,5)
  1.  Q:$P(SEG,DL1,3)'="LABORATORY"
  1.  S SEG=$$SEG("PID",.LP)
  1.  Q:'LP
  1.  S DFN=+$P(SEG,DL1,4)
  1.  Q:'DFN
  1.  S SEG=$$SEG("PV1",.LP)
  1.  Q:'LP
  1.  S LOC=+$P($P(SEG,DL1,4),DL2)
  1.  S CAT=$S($P(SEG,DL1,3)="I":"I",1:"A")
  1.  S SEG=$$SEG("ORC",.LP)
  1.  Q:'LP
  1.  S STATUS=$P(SEG,DL1,6)          ; Order status
  1.  S OIEN=$P($P(SEG,DL1,3),DL2)    ; OE/RR order number
  1.  Q:'OIEN                         ; Must have an OE/RR order number
  1.  S LABORDF=$P($P(SEG,DL1,4),DL2) ; Lab order information
  1.  S LABORD=$P(LABORDF,";")        ; Lab order number w/File 69 ref
  1.  S LODT=$P(LABORDF,";",2)        ; Lab order date
  1.  S LSEQ=$P(LABORDF,";",3)        ; Lab order seq number
  1.  S CONTROL=$P(SEG,DL1,2)
  1.  S PRV=+$P(SEG,DL1,13)                    ; Ordering Provider
  1.  S ODT=$$FMDATE^LR7OU0($P(SEG,DL1,16))    ; Order effective Date/Time
  1.  S CMPDT=$$FMDATE^LR7OU0($P($P(SEG,DL1,8),U,5))    ; Complete Date/Time
  1.  ;
  1.  I CONTROL?2U,$L($T(@CONTROL)) D @CONTROL
  1.  Q
  1. SN ; New Order
  1.  ; Currently not used
  1.  Q
  1. SC ; Status Change
  1.  N DAT,LP1,TSTARY,VSIT,ERR,TST,FLN,SUB,LOINC
  1.  N RES,AFLG,ORG,ATB,COLSPL,CMPDT,UNITS,RLOW,RHIGH,ORG,ATB
  1.  N CMPDT
  1.  S SEG=$$SEG("OBR",.LP)
  1.  Q:'LP
  1.  S TST=+$P($P(SEG,DL1,5),DL2,4)     ; Primary test
  1.  S CDT=$$FMDATE^LR7OU0($P(SEG,DL1,8))                ; Collection Date/Time
  1.  S SPEC=$P($P($P(SEG,DL1,16),DL2,4),";")  ;Specimen pointer to File 61
  1.  S COLSPL=$P($P(SEG,DL1,16),";",4)  ; Collection Sample to File 62
  1.  S ACC=$P(SEG,DL1,21)               ; Accession Number
  1.  S VSTAT="A"                        ; V File Status
  1.  S TCST=$$GET1^DIQ(60,TST,1,"E")    ; Test cost
  1.  S SUB=$$GET1^DIQ(60,TST,4,"I")     ; Subscript
  1.  S LOINC=$$LOINC^CIAZPLCH(TST,SPEC)          ; LOINC Code associated with test/specimen
  1.  S (UNITS,RLOW,RHIGH,ORG,ATB)=""
  1.  S FLN=$S(SUB="MI":.25,SUB="BB":.31,1:.09)   ; V File based on Subscript
  1.  D GETCPT^CIAZPLCH(TST,ODT,.DAT)
  1.  S CPTP=$G(DAT("CPTPTR"))
  1.  S CPTCODE=$G(DAT("CPTCODES"))
  1.  S ACT="LR"_$S(SUB="MI":"M",SUB="BB":"B",1:"C")_"+"  ;todo - are +- needed
  1.  S (RES,AFLG,ORG,ATB,CMPDT)=""
  1.  D ADD("HDR^^^"_LOC_";"_ODT_";"_CAT_";")
  1.  D ADD("VST^PT^"_DFN)
  1.  D ADD("VST^DT^"_ODT)
  1.  D ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV_U_TCST_U_SPEC_U_COLSPL)
  1.  D GETCOM(.DAT)
  1.  D:$D(DAT(1)) ADD("COM^1^"_DAT(1))
  1.  D:$D(DAT(2)) ADD("COM^2^"_DAT(2))
  1.  D:$D(DAT(3)) ADD("COM^3^"_DAT(3))
  1.  ; Add Panel Tests - returns expanded panel plus original test
  1.  D EXPAND^LR7OU1(TST,.TSTARY)
  1.  I $D(TSTARY) D
  1.  .K TSTARY(TST)  ; remove original test
  1.  .S TST="" F  S TST=$O(TSTARY(TST)) Q:TST=""  D
  1.  ..S FLN=$S($$GET1^DIQ(60,TST,4,"I")="MI":.25,SUB="BB":.31,1:.09)   ; V File based on Subscript
  1.  ..S TCST=$$GET1^DIQ(60,TST,1,"E")     ; Test Cost
  1.  ..D ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV_U_TCST_U_SPEC_U_COLSPL)
  1.  D SAVE
  1.  Q
  1.  ;
  1. RE ; Result Message
  1.  N DAT,LP1,TSTARY,VSIT,ERR,TST,FLN,RLOW,RHIGH
  1.  N RES,AFLG,ORG,ATB,COLSPL,SUB,SPEC,RESDT,PTST
  1.  Q:$$FINDNODE(.MSG,"OBX")<0               ; Result message without OBX segment
  1.  S SEG=$$SEG("OBR",.LP)
  1.  Q:'LP
  1.  S TST=+$P($P(SEG,DL1,5),DL2,4)           ; Primary test
  1.  S CDT=$$FMDATE^LR7OU0($P(SEG,DL1,8))     ; Collection Date/Time
  1.  S SPEC=$P($P($P(SEG,DL1,16),DL2,4),";")  ; Specimen pointer to File 61
  1.  S COLSPL=$P($P(SEG,DL1,16),";",4)  ; Collection Sample to File 62
  1.  S ACC=$P(SEG,DL1,21)                     ; Accession Number
  1.  S VSTAT="R"                              ; V File Status
  1.  S SUB=$$GET1^DIQ(60,TST,4,"I")
  1.  S FLN=$S(SUB="MI":.25,SUB="BB":.31,1:.09)   ; V File based on Subscript
  1.  S ACT="LR"_$S(SUB="MI":"M",SUB="BB":"B",1:"C")  ;todo - are +- needed
  1.  S (TCST,RES,AFLG,ORG,ATB)=""
  1.  D ADD("HDR^^^"_LOC_";"_ODT_";"_CAT_";")
  1.  D ADD("VST^PT^"_DFN)
  1.  D ADD("VST^DT^"_ODT)
  1.  D GETCOM(.DAT)
  1.  D:$D(DAT(1)) ADD("COM^1^"_DAT(1))
  1.  D:$D(DAT(2)) ADD("COM^2^"_DAT(2))
  1.  D:$D(DAT(3)) ADD("COM^3^"_DAT(3))
  1.  ; Save OBR data
  1.  S PTST=TST
  1.  D SETADD
  1.  F  S SEG=$$SEG("OBX",.LP) Q:'LP  D
  1.  .S PTST=$P($P(SEG,DL1,4),U,4) Q:'$$VALTST(PTST)
  1.  .I PTST["ANTIBODY SCREEN INTERPRETATION" D
  1.  ..D COOMBS
  1.  .E  I PTST["ABO INTERPRETATION"!(PTST["RH  INTERPRETATION") D
  1.  ..S PTST=$TR(PTST,"  "," ")
  1.  ..S RES=$P(SEG,DL1,6)
  1.  ..D SETADD
  1.  D SAVE
  1.  Q
  1.  ; Order Cancel message
  1. OC ;
  1.  N DAT,LP1,TSTARY,VSIT,ERR,TST,FLN,SUB,COLSPL
  1.  S SEG=$$SEG("OBR",.LP)
  1.  Q:'LP
  1.  S TST=+$P($P(SEG,DL1,5),DL2,4)     ; Primary test
  1.  S ACC=$P(SEG,DL1,21)               ; Accession Number
  1.  S VSTAT="D"                        ; V File Status
  1.  S SUB=$$GET1^DIQ(60,TST,4,"I")     ; Subscript
  1.  S (TCST,UNITS,RLOW,RHIGH,ORG,ATB,COLSPL,CDT)=""
  1.  S FLN=$S(SUB="MI":.25,SUB="BB":.31,1:.09)   ; V File based on Subscript
  1.  S ACT="LR"_$S(SUB="MI":"M",SUB="BB":"B",1:"C")_"-"
  1.  D ADD("HDR^^^"_LOC_";"_ODT_";"_CAT_";")
  1.  D ADD("VST^PT^"_DFN)
  1.  D ADD("VST^DT^"_ODT)
  1.  D ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV)
  1.  ; Add Panel Tests - returns expanded panel plus original test
  1.  D EXPAND^LR7OU1(TST,.TSTARY)
  1.  I $D(TSTARY) D
  1.  .K TSTARY(TST)  ; remove original test
  1.  .S TST="" F  S TST=$O(TSTARY(TST)) Q:TST=""  D
  1.  ..S FLN=$S($$GET1^DIQ(60,TST,4,"I")="MI":.25,SUB="BB":.31,1:.09)   ; V File based on Subscript
  1.  ..D ADD(ACT_U_TST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV)
  1.  D SAVE
  1.  ;
  1. SAVE L +^CIAZPLBB(OIEN):30
  1.  I  D
  1.  .D SAVE^CIAVCXPC(.ERR,.PCC)
  1.  .L -^CIAZPLBB(OIEN)
  1.  E  S ERR="-1^Timeout while trying to lock record."
  1.  ;I 'ERR,ORD?2U,$L($T(@ORD)) D @ORD
  1.  D:ERR BUL
  1.  Q
  1.  ; Add to PCC array
  1. ADD(X,Y) ;
  1.  I +$G(Y) D
  1.  .S PCC(Y)=X
  1.  E  S PCC=$G(PCC)+1,PCC(PCC)=X
  1.  Q
  1.  ; Find a node in PCC array
  1. FINDNODE(ARY,VAL) ;
  1.  N LP
  1.  S LP=0 F  S LP=$O(ARY(LP)) Q:'LP  Q:$E(ARY(LP),1,$L(VAL))=VAL
  1.  Q $S(LP:LP,1:-1)
  1.  ; Return specified segment, starting at line LP
  1. SEG(TYP,LP) ;
  1.  F  S LP=$O(MSG(LP)) Q:'LP  Q:$E(MSG(LP),1,$L(TYP))=TYP
  1.  Q $S(LP:MSG(LP),1:"")
  1.  ; Send a bulletin on error
  1. BUL N XMB,XMTEXT,XMY,XMDUZ,XMDT,XMYBLOB,XMZ
  1.  S XMB="APCD PCC PACKAGE LINK FAIL"
  1.  S XMB(1)=OIEN
  1.  S XMB(2)=$P($G(^DPT(DFN,0)),U)
  1.  S XMB(3)=LABORD
  1.  S XMB(4)=$$FMTE^XLFDT(ODT)
  1.  S XMB(5)=$P(ERR,U,2)
  1.  S XMDUZ=.5
  1.  D ^XMB
  1.  Q
  1.  ; Return comments
  1. GETCOM(ARY) ;
  1.  N CNT,LP
  1.  K ARY
  1.  S CNT=0,LP=0
  1.  F  S LP=$O(MSG(LP),-1) Q:'LP  I $E(MSG(LP),1,3)="NTE" D
  1.  .S CNT=CNT+1,ARY(CNT)=$P(MSG(LP),DL1,4)
  1.  Q
  1. VALTST(TST) ;
  1.  Q:TST="ANTIBODY SCREEN INTERPRETATION" 1
  1.  Q:TST="ABO INTERPRETATION" 1
  1.  Q:TST="RH  INTERPRETATION" 1
  1.  Q 0
  1.  ;
  1. COOMBS ;
  1.  N ATB
  1.  S ATB=""
  1.  I $E($G(DR),2,5)="LRBL" D
  1.  .I $D(^LR(LRDFN,"BB",LRI,2)) D    ; Sets naked reference
  1.  ..S RES=$P($G(^(2)),U,9)
  1.  ..S PTST="DIRECT INTERPRETATION"
  1.  ..D SETADD
  1.  ..S ATB=0 F  S ATB=$O(^LR(LRDFN,"BB",LRI,"EA",ATB)) Q:'ATB  D
  1.  ...S RES="POS"
  1.  ...D SETADD
  1.  .I $D(^LR(LRDFN,"BB",LRI,6)) D   ; Sets naked reference
  1.  ..S RES=$G(^(6))
  1.  ..S PTST="INDIRECT INTERPRETATION"
  1.  ..D SETADD
  1.  ..Q:RES="N"
  1.  ..S RES="POS"
  1.  ..S ATB=0 F  S ATB=$O(^LR(LRDFN,"BB",LRI,5,ATB)) Q:'ATB  D
  1.  ...D SETADD
  1.  Q
  1.  ;
  1. SETADD ;
  1.  D ADD(ACT_U_PTST_U_FLN_U_VSTAT_U_ACC_U_LABORDF_U_ODT_U_CDT_U_PRV_U_TCST_U_SPEC_U_COLSPL_U_RES_U_CMPDT_U_ATB)
  1.  Q