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

LRBEBAO.m

Go to the documentation of this file. 
  1. LRBEBAO ;DALOI/JAH/FHS - ORDERING AND RESULTING FOR OUTPATIENTS ; 17-Oct-2014 09:22 ; MKK
  1.  ;;5.2;LAB SERVICE;**291,359,352,1031,1033,1034**;Nov 1, 1997;Build 88
  1.  ;
  1.  ; This routine contains the subroutines that get the diagnosis pointers
  1.  ; and indicators at order entry and result verification for outpatient.
  1.  ;
  1.  ; Reference to EN^DDIOL supported by IA #10142
  1.  ; Reference to ^DIC supported by IA #10006
  1.  ; Reference to $$GET1^DIQ supported by IA #2056
  1.  ; Reference to ^DIR supported by IA #10026
  1.  ; Reference to ^ICD9 supported by IA #10082
  1.  ; Reference to ^DIC(9.4 supported by IA #10048
  1.  ; Reference to ^DIC(81.3 supported by IA #2816
  1.  ;
  1. OPORD ; Outpatient Order Entry
  1.  ;
  1.  ; Input:
  1.  ;  LRBEDFN    - Patient's DFN (#2)
  1.  ;  LRBESMP    - Sample
  1.  ;  LRBESPC    - Specimen
  1.  ;  LRBETST    - Ordered Test
  1.  ;  LRBEDGX    - Pointer to Diagnosis (#80)
  1.  ;  LRBEAR(LRBEDFN,"DOS")      - Date of Service
  1.  ;  LRBEAR(LRBEDFN,"PAT")      - Patient DFN (#2)
  1.  ;  LRBEAR(LRBEDFN,"POS")      - Place of Service
  1.  ;  LRBEAR(LRBEDFN,"ORDGX")    - Ordering or Resulting Diagnosis
  1.  ;  LRBEAR(LRBEDFN,"USR")      - User
  1.  ;  LRBEAR(LRBEDFN,"ORDPRO")    - Ordering Provider
  1.  ;  LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX)
  1.  ;   Piece     Desc
  1.  ;   -----     ---------------------------------
  1.  ;   1     -   Diagnosis
  1.  ;   2     -   Unused (blank)
  1.  ;   3     -   Textual Description of  Diagnosis
  1.  ;   4     -   Agent Orange
  1.  ;   5     -   Ionizing Radiation
  1.  ;   6     -   Service Connected Indicator
  1.  ;   7     -   Environmental Contaminamts
  1.  ;   8     -   MST (Military Sexual Tramua)
  1.  ;   9     -   Head and Neck Cancer
  1.  ;   10    -   Combat Veteran
  1.  ;
  1.  ; Output:
  1.  ;  LRBEAR1(VISIT,TST,LRBEPOV)=LRBEDGX
  1.  ;   VISIT      -  Pointer to VISIT (9000010) file
  1.  ;   TST        -  Ordered Test
  1.  ;   LRBEPOV        -  Pointer to V POV (#9000010.07) file
  1.  ;   LRBEDGX        -  Pointer to Diagnosis (#80)
  1. EN ;
  1.  Q:$$MODEXIST^BLRUTIL4("PCE")<1   ; IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1.  D INIT
  1.  S SUB1="ENCOUNTER",SUB2="DX/PL",SUB3="PROVIDER"
  1.  S LRBEDFN="" F  S LRBEDFN=$O(LRBEAR(LRBEDFN)) Q:LRBEDFN=""  D
  1.  .S LRBETM=$S($P($G(LRBECDT),".",2):LRBECDT,$G(LRCDT):LRCDT,1:DT)
  1.  .S LRBETM=$$PCETM(LRBETM)
  1.  .S ^TMP("LRPXAPI",$J,SUB1,1,"ENC D/T")=LRBETM
  1.  .S ^TMP("LRPXAPI",$J,SUB1,1,"DSS ID")=LROOS
  1.  .S ^TMP("LRPXAPI",$J,SUB1,1,"HOS LOC")=$G(LRBEAR(LRBEDFN,"POS"))
  1.  .S ^TMP("LRPXAPI",$J,SUB1,1,"PATIENT")=$G(LRBEAR(LRBEDFN,"PAT"))
  1.  .S ^TMP("LRPXAPI",$J,SUB1,1,"SERVICE CATEGORY")="X"
  1.  .S ^TMP("LRPXAPI",$J,SUB1,1,"ENCOUNTER TYPE")="A"
  1.  .S ^TMP("LRPXAPI",$J,SUB3,1,"NAME")=$G(LRBEAR(LRBEDFN,"ORDPRO"))
  1.  .S ^TMP("LRPXAPI",$J,SUB3,1,"PRIMARY")=1
  1.  .I $G(LRBEAR(LRBEDFN,"DEL")) D
  1.  ..S ^TMP("LRPXAPI",$J,SUB1,1,"DELETE")=$G(LRBEAR(LRBEDFN,"DEL"))
  1.  .S LRBESMP=""
  1.  .F  S LRBESMP=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP)) Q:LRBESMP=""  D
  1.  ..S LRBESPC=""
  1.  ..F  S LRBESPC=+$O(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC)) Q:LRBESPC<1  D
  1.  ...D OPWRK
  1.  Q
  1.  ;
  1. OPWRK ; More Outpatient Work
  1.  N X,XX,B,BG,N,DX,LRBEDIA
  1.  ;get all primary (n=1) and secondary (n=2) dx
  1.  S LRBETST="" F  S LRBETST=$O(LRBECPT(LRBETST)) Q:'LRBETST  D
  1.  . S LRBETNUM=0 F  S LRBETNUM=$O(LRBECPT(LRBETST,LRBETNUM)) Q:LRBETNUM<1  D
  1.  . . S LRBEDGX=""
  1.  . . F  S LRBEDGX=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX)) Q:LRBEDGX=""  D
  1.  . . . S LRBEPTDT=$G(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX))
  1.  . . . S N=$S($P(LRBEPTDT,U,12):1,1:2),X=$P(LRBEPTDT,U,4,11)
  1.  . . . ;collapse indicators for same dx
  1.  . . . S XX=$G(DX(N,LRBEDGX))
  1.  . . . F B=1:1:8 I $P(XX,U,B)'=1,$P(X,U,B)'="" S $P(XX,U,B)=$P(X,U,B)
  1.  . . . S DX(N,LRBEDGX)=XX
  1.  ;set primary dx in PCE array
  1.  S LRBEDGX=""
  1.  F  S LRBEDGX=$O(DX(1,LRBEDGX)) Q:LRBEDGX=""  D
  1.  . S LRBEDIA=$G(LRBEDIA)+1,XX=DX(1,LRBEDGX)
  1.  . S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,"DIAGNOSIS")=LRBEDGX
  1.  . S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,"PRIMARY")=1
  1.  . F B=1:1:8 I $P(XX,U,B)'="" D
  1.  . . S BG=$$GETT(B)
  1.  . . I '$G(^TMP("LRPXAPI",$J,SUB2,LRBEDIA,BG)) S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,BG)=$P(XX,U,B)
  1.  . . ;collapse dx indicators into encounter node
  1.  . . I '$G(^TMP("LRPXAPI",$J,SUB1,1,$P(BG," ",2))) S ^TMP("LRPXAPI",$J,SUB1,1,$P(BG," ",2))=$P(XX,U,B)
  1.  ;set secondary dx in PCE array
  1.  S LRBEDGX=""
  1.  F  S LRBEDGX=$O(DX(2,LRBEDGX)) Q:LRBEDGX=""  D
  1.  . S LRBEDIA=$G(LRBEDIA)+1,XX=DX(2,LRBEDGX)
  1.  . S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,"DIAGNOSIS")=LRBEDGX
  1.  . F B=1:1:8 I $P(XX,U,B)'="" D
  1.  . . S BG=$$GETT(B)
  1.  . . I '$G(^TMP("LRPXAPI",$J,SUB2,LRBEDIA,BG)) S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,BG)=$P(XX,U,B)
  1.  . . ;collapse dx indicators into encounter node
  1.  . . I '$G(^TMP("LRPXAPI",$J,SUB1,1,$P(BG," ",2))) S ^TMP("LRPXAPI",$J,SUB1,1,$P(BG," ",2))=$P(XX,U,B)
  1.  Q
  1.  ;
  1. GETT(X) ; Indicators for ^TMP
  1.  I '+X Q ""
  1.  Q "PL "_$S(X=1:"AO",X=2:"IR",X=3:"SC",X=4:"EC",X=5:"MST",X=6:"HNC",X=7:"CV",X=8:"SHAD",1:"")
  1.  ;
  1. OPRES(LRBEAR,LRBEAR1,LRODT,LRSN,LRBEVST) ; Outpatient Final Resulting
  1.  Q:'$$MODEXIST^BLRUTIL4("PCE")                   ; IHS/MSC/MKK - LR*5.2*1031
  1.  ;
  1.  ; Inputs:
  1.  ;  LRBEDN    -  Data Number of Test in #63 field 400
  1.  ;  LRBEAR(LRBEDFN,"VST")     -  Patient's Encounter Number #9000010
  1.  ;  LRBEAR(LRBEDFN,"LRBEDGX",LRBEDN)
  1.  ;   Piece     Desc
  1.  ;   1     -   Procedure (CPT)
  1.  ;   2     -   Modifiers (Sub-delimited by "~")
  1.  ;   3     -   Diagnosis
  1.  ;   4     -   Diagnosis 2
  1.  ;   5     -   Diagnosis 3
  1.  ;   6     -   Diagnosis 4
  1.  ;   7     -   Event D/T  (DOS)
  1.  ;   8     -   Encounter Provider
  1.  ;   9     -   Ordering Provider
  1.  ;   10    -   Quantity (Number of times procedure was performed)
  1.  ;   11    -   Place of Service 
  1.  ; Output:
  1.  ;  LRBEAR1(VISIT,TST,LRBEPOV)=LRBEDGX
  1.  ;   VISIT      -  Pointer to VISIT (9000010) file
  1.  ;   TST        -  Ordered Test
  1.  ;   LRBEPOV        -  Pointer to V POV (#9000010.07) file
  1.  ;   LRBEDGX        -  Pointer to Diagnosis (#80)
  1.  ;
  1.  D INIT
  1.  N LRSWSTAT,LRSWDATE
  1.  ;
  1.  S LRSWSTAT=$$SWSTAT^IBBAPI
  1.  S LRSWDATE=+$P(LRSWSTAT,U,2)
  1.  S LRSWSTAT=+$P(LRSWSTAT,U)
  1.  S SUB1="PROCEDURE"
  1.  I '$G(LRDBEDGX) D
  1.  . N LRX
  1.  . S (LRDBEDGX,LRX)=0
  1.  . F  S LRX=$O(^LRO(69,LRODT,1,LRSN,2,LRX)) Q:LRX<1!($G(LRDBEDGX))  D
  1.  . . ;set a default diagnosis and sc/ei indicators
  1.  . . I $G(^LRO(69,LRODT,1,LRSN,2,LRX,2,1,0)) S LRDBEDGX=+^(0)
  1.  S LRBEDFN="" F  S LRBEDFN=$O(LRBEAR(LRBEDFN)) Q:LRBEDFN=""  D
  1.  . S LRI=0 F  S LRI=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRI)) Q:LRI<1  D
  1.  . . D OPWRK2
  1.  ;microbiology results sent to PCE in LRCAPPH1
  1.  I $P($G(^LRO(68,$G(LRAA),0)),U,2)'="MI" D SEND
  1.  Q
  1. SEND ; Send if procedure is defined
  1.  Q:$$MODEXIST^BLRUTIL4("PCE")<1   ; IHS/MSC/MKK - LR*5.2*1033 [00134902]
  1.  ;
  1.  N LRLNOW,LRVX,PXALOOK,PXUCV
  1.  I '$G(^TMP("LRPXAPI",$J,"PROCEDURE",1,"PROCEDURE")) G END
  1.  I $G(^XTMP("LRPCELOG",0)) D
  1.  . F  S LRLNOW=$$NOW^XLFDT Q:'$D(^XTMP("LRPCELOG",1,LRLNOW))
  1.  . N LRACCX,LRUIDX
  1.  . S LRACCX=$G(LRACC),LRUIDX=$G(LRUID)
  1.  . M ^XTMP("LRPCELOG",2,LRLNOW)=^TMP("LRPXAPI",$J)
  1.  . S ^XTMP("LRPCELOG",2,LRLNOW,0)=LRACCX_U_LRUIDX
  1.  S LRVX=$$DATA2PCE^PXAPI(INROOT,LRPKG,SRC,.LRBEVSIT,USR,ERRDIS)
  1.  I $D(^XTMP("LRPCELOG",2,+$G(LRLNOW),0)) D
  1.  . S $P(^XTMP("LRPCELOG",2,+$G(LRLNOW),0),U,3,4)=LRVX_U_LRBEVSIT
  1.  . M ^XTMP("LRPCELOG",2,LRLNOW)=^TMP("LRPXAPI",$J)
  1.  I $G(LRBEVSIT) D SVST^LRBEBA3(LRBEVSIT,"PCE",LRODT,LRSN)
  1. END K ^TMP("LRPXAPI",$J),LRBETNUM
  1.  Q
  1.  ;
  1. OPWRK2 ; Outpatient Work Two
  1.  K LRBEPTDT
  1.  S LRBEDN=0 F  S LRBEDN=+$O(LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBEDN)) Q:LRBEDN<1  D OPWRK3
  1.  Q
  1. OPWRK3 ;
  1.  N JJ
  1.  S LRBEPTDT=$G(LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBEDN))
  1.  Q:'($L(LRBEPTDT))
  1.  I '$P(LRBEPTDT,U,3) D
  1.  .S $P(LRBEPTDT,U,3)=LRDBEDGX
  1.  .S JJ=$O(^TMP("LRPXAPI",$J,"DX/PL",99),-1)+1
  1.  .S ^TMP("LRPXAPI",$J,"DX/PL",JJ,"DIAGNOSIS")=LRDBEDGX
  1.  .I JJ=1 S ^TMP("LRPXAPI",$J,"DX/PL",JJ,"PRIMARY")=1
  1.  .E  S ^TMP("LRPXAPI",$J,"DX/PL",JJ,"PRIMARY")=0
  1.  S LRBETNUM=$G(LRBETNUM)+1,LRBEIEN=LRSN_","_LRODT_","
  1.  I $P(LRBEPTDT,U,1)'="" D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"PROCEDURE")=$P(LRBEPTDT,U,1)
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"QTY")=1
  1.  I $P(LRBEPTDT,U,2)'="" D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"MODIFIERS",$P(LRBEPTDT,U,2))=""
  1.  I $P(LRBEPTDT,U,3)'="" D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS")=$P(LRBEPTDT,U,3)
  1.  I $P(LRBEPTDT,U,4)'="" D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 2")=$P(LRBEPTDT,U,4)
  1.  I $P(LRBEPTDT,U,5)'="" D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 3")=$P(LRBEPTDT,U,5)
  1.  I $P(LRBEPTDT,U,6)'="" D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 4")=$P(LRBEPTDT,U,6)
  1.  I $P(LRBEPTDT,U,7)'="" D
  1.  . N LRBETM S LRBETM=$P(LRBEPTDT,U,7)
  1.  . S LRBETM=$$PCETM(LRBETM)
  1.  . S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"EVENT D/T")=LRBETM
  1.  I $P(LRBEPTDT,U,8)'="" D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"ENC PROVIDER")=$P(LRBEPTDT,U,8)
  1.  I $P(LRBEPTDT,U,9)>0 D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"ORD PROVIDER")=$P(LRBEPTDT,U,9)
  1.  I $P(LRBEPTDT,U,10)'="" D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"QTY")=$P(LRBEPTDT,U,10)
  1.  I $P(LRBEPTDT,U,12)'="" D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 5")=$P(LRBEPTDT,U,12)
  1.  I $P(LRBEPTDT,U,13)'="" D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 6")=$P(LRBEPTDT,U,13)
  1.  I $P(LRBEPTDT,U,14)'="" D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 7")=$P(LRBEPTDT,U,14)
  1.  I $P(LRBEPTDT,U,15)'="" D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 8")=$P(LRBEPTDT,U,15)
  1.  I $P(LRBEPTDT,U,16)'="" D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"ORD REFERENCE")=$P(LRBEPTDT,U,16)
  1.  I LRSWSTAT,($P(LRBETM,".")'<LRSWDATE) D
  1.  .S ^TMP("LRPXAPI",$J,"PROCEDURE",LRBETNUM,"DEPARTMENT")=108
  1.  I $P(LRBEPTDT,U,20)'="" D
  1.  .S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"QTY")=$P(LRBEPTDT,U,20)
  1.  I $G(^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS"))=0 K ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS")
  1.  Q
  1.  ;
  1. INIT ;Setup PCE variables
  1.  S INROOT="^TMP(""LRPXAPI"",$J)"
  1.  I '$G(LRPKG) D  Q:'$G(LRPKG)
  1.  . S X="LAB SERVICE",DIC="^DIC(9.4,",DIC(0)="Z" D ^DIC
  1.  . I Y S LRPKG=+Y
  1.  S SRC="LAB DATA",USR=DUZ,(LRBETNUM,ERRDIS)=0
  1.  K DIC
  1.  Q
  1. PCETM(LRBETM) ;Return date/time without seconds
  1.  N PCETM
  1.  S LRBETM=$G(LRBETM)
  1.  Q:'LRBETM LRBETM
  1.  S PCETM=$E($P(LRBETM,".",2),1,4)
  1.  F  Q:($L(PCETM)=4)  S PCETM=PCETM_0
  1.  I PCETM>2359 S PCETM=2359
  1.  I $E(PCETM,3,4)>59 S PCETM=$E(PCETM,1,2)_59
  1.  I 'PCETM S PCETM="0001"
  1.  S $P(LRBETM,".",2)=PCETM
  1.  Q LRBETM