LRBEBAO ;DALOI/JAH/FHS - ORDERING AND RESULTING FOR OUTPATIENTS ;8/10/04
;;5.2;LAB SERVICE;**291,359,352**;Sep 27, 1994;Build 1
;
; This routine contains the subroutines that get the diagnosis pointers
; and indicators at order entry and result verification for outpatient.
;
; Reference to EN^DDIOL supported by IA #10142
; Reference to ^DIC supported by IA #10006
; Reference to $$GET1^DIQ supported by IA #2056
; Reference to ^DIR supported by IA #10026
; Reference to ^ICD9 supported by IA #10082
; Reference to ^DIC(9.4 supported by IA #10048
; Reference to ^DIC(81.3 supported by IA #2816
;
OPORD ; Outpatient Order Entry
;
; Input:
; LRBEDFN - Patient's DFN (#2)
; LRBESMP - Sample
; LRBESPC - Specimen
; LRBETST - Ordered Test
; LRBEDGX - Pointer to Diagnosis (#80)
; LRBEAR(LRBEDFN,"DOS") - Date of Service
; LRBEAR(LRBEDFN,"PAT") - Patient DFN (#2)
; LRBEAR(LRBEDFN,"POS") - Place of Service
; LRBEAR(LRBEDFN,"ORDGX") - Ordering or Resulting Diagnosis
; LRBEAR(LRBEDFN,"USR") - User
; LRBEAR(LRBEDFN,"ORDPRO") - Ordering Provider
; LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX)
; Piece Desc
; ----- ---------------------------------
; 1 - Diagnosis
; 2 - Unused (blank)
; 3 - Textual Description of Diagnosis
; 4 - Agent Orange
; 5 - Ionizing Radiation
; 6 - Service Connected Indicator
; 7 - Environmental Contaminamts
; 8 - MST (Military Sexual Tramua)
; 9 - Head and Neck Cancer
; 10 - Combat Veteran
;
; Output:
; LRBEAR1(VISIT,TST,LRBEPOV)=LRBEDGX
; VISIT - Pointer to VISIT (9000010) file
; TST - Ordered Test
; LRBEPOV - Pointer to V POV (#9000010.07) file
; LRBEDGX - Pointer to Diagnosis (#80)
EN ;
D INIT
S SUB1="ENCOUNTER",SUB2="DX/PL",SUB3="PROVIDER"
S LRBEDFN="" F S LRBEDFN=$O(LRBEAR(LRBEDFN)) Q:LRBEDFN="" D
.S LRBETM=$S($P($G(LRBECDT),".",2):LRBECDT,$G(LRCDT):LRCDT,1:DT)
.S LRBETM=$$PCETM(LRBETM)
.S ^TMP("LRPXAPI",$J,SUB1,1,"ENC D/T")=LRBETM
.S ^TMP("LRPXAPI",$J,SUB1,1,"DSS ID")=LROOS
.S ^TMP("LRPXAPI",$J,SUB1,1,"HOS LOC")=$G(LRBEAR(LRBEDFN,"POS"))
.S ^TMP("LRPXAPI",$J,SUB1,1,"PATIENT")=$G(LRBEAR(LRBEDFN,"PAT"))
.S ^TMP("LRPXAPI",$J,SUB1,1,"SERVICE CATEGORY")="X"
.S ^TMP("LRPXAPI",$J,SUB1,1,"ENCOUNTER TYPE")="A"
.S ^TMP("LRPXAPI",$J,SUB3,1,"NAME")=$G(LRBEAR(LRBEDFN,"ORDPRO"))
.S ^TMP("LRPXAPI",$J,SUB3,1,"PRIMARY")=1
.I $G(LRBEAR(LRBEDFN,"DEL")) D
..S ^TMP("LRPXAPI",$J,SUB1,1,"DELETE")=$G(LRBEAR(LRBEDFN,"DEL"))
.S LRBESMP=""
.F S LRBESMP=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP)) Q:LRBESMP="" D
..S LRBESPC=""
..F S LRBESPC=+$O(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC)) Q:LRBESPC<1 D
...D OPWRK
Q
;
OPWRK ; More Outpatient Work
N X,XX,B,BG,N,DX,LRBEDIA
;get all primary (n=1) and secondary (n=2) dx
S LRBETST="" F S LRBETST=$O(LRBECPT(LRBETST)) Q:'LRBETST D
. S LRBETNUM=0 F S LRBETNUM=$O(LRBECPT(LRBETST,LRBETNUM)) Q:LRBETNUM<1 D
. . S LRBEDGX=""
. . F S LRBEDGX=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX)) Q:LRBEDGX="" D
. . . S LRBEPTDT=$G(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX))
. . . S N=$S($P(LRBEPTDT,U,12):1,1:2),X=$P(LRBEPTDT,U,4,11)
. . . ;collapse indicators for same dx
. . . S XX=$G(DX(N,LRBEDGX))
. . . F B=1:1:8 I $P(XX,U,B)'=1,$P(X,U,B)'="" S $P(XX,U,B)=$P(X,U,B)
. . . S DX(N,LRBEDGX)=XX
;set primary dx in PCE array
S LRBEDGX=""
F S LRBEDGX=$O(DX(1,LRBEDGX)) Q:LRBEDGX="" D
. S LRBEDIA=$G(LRBEDIA)+1,XX=DX(1,LRBEDGX)
. S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,"DIAGNOSIS")=LRBEDGX
. S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,"PRIMARY")=1
. F B=1:1:8 I $P(XX,U,B)'="" D
. . S BG=$$GETT(B)
. . I '$G(^TMP("LRPXAPI",$J,SUB2,LRBEDIA,BG)) S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,BG)=$P(XX,U,B)
. . ;collapse dx indicators into encounter node
. . I '$G(^TMP("LRPXAPI",$J,SUB1,1,$P(BG," ",2))) S ^TMP("LRPXAPI",$J,SUB1,1,$P(BG," ",2))=$P(XX,U,B)
;set secondary dx in PCE array
S LRBEDGX=""
F S LRBEDGX=$O(DX(2,LRBEDGX)) Q:LRBEDGX="" D
. S LRBEDIA=$G(LRBEDIA)+1,XX=DX(2,LRBEDGX)
. S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,"DIAGNOSIS")=LRBEDGX
. F B=1:1:8 I $P(XX,U,B)'="" D
. . S BG=$$GETT(B)
. . I '$G(^TMP("LRPXAPI",$J,SUB2,LRBEDIA,BG)) S ^TMP("LRPXAPI",$J,SUB2,LRBEDIA,BG)=$P(XX,U,B)
. . ;collapse dx indicators into encounter node
. . I '$G(^TMP("LRPXAPI",$J,SUB1,1,$P(BG," ",2))) S ^TMP("LRPXAPI",$J,SUB1,1,$P(BG," ",2))=$P(XX,U,B)
Q
;
GETT(X) ; Indicators for ^TMP
I '+X Q ""
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:"")
;
OPRES(LRBEAR,LRBEAR1,LRODT,LRSN,LRBEVST) ; Outpatient Final Resulting
; Inputs:
; LRBEDN - Data Number of Test in #63 field 400
; LRBEAR(LRBEDFN,"VST") - Patient's Encounter Number #9000010
; LRBEAR(LRBEDFN,"LRBEDGX",LRBEDN)
; Piece Desc
; 1 - Procedure (CPT)
; 2 - Modifiers (Sub-delimited by "~")
; 3 - Diagnosis
; 4 - Diagnosis 2
; 5 - Diagnosis 3
; 6 - Diagnosis 4
; 7 - Event D/T (DOS)
; 8 - Encounter Provider
; 9 - Ordering Provider
; 10 - Quantity (Number of times procedure was performed)
; 11 - Place of Service
; Output:
; LRBEAR1(VISIT,TST,LRBEPOV)=LRBEDGX
; VISIT - Pointer to VISIT (9000010) file
; TST - Ordered Test
; LRBEPOV - Pointer to V POV (#9000010.07) file
; LRBEDGX - Pointer to Diagnosis (#80)
;
D INIT
N LRSWSTAT,LRSWDATE
S LRSWSTAT=$$SWSTAT^IBBAPI
S LRSWDATE=+$P(LRSWSTAT,U,2)
S LRSWSTAT=+$P(LRSWSTAT,U)
S SUB1="PROCEDURE"
I '$G(LRDBEDGX) D
. N LRX
. S (LRDBEDGX,LRX)=0
. F S LRX=$O(^LRO(69,LRODT,1,LRSN,2,LRX)) Q:LRX<1!($G(LRDBEDGX)) D
. . ;set a default diagnosis and sc/ei indicators
. . I $G(^LRO(69,LRODT,1,LRSN,2,LRX,2,1,0)) S LRDBEDGX=+^(0)
S LRBEDFN="" F S LRBEDFN=$O(LRBEAR(LRBEDFN)) Q:LRBEDFN="" D
. S LRI=0 F S LRI=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRI)) Q:LRI<1 D
. . D OPWRK2
;microbiology results sent to PCE in LRCAPPH1
I $P($G(^LRO(68,$G(LRAA),0)),U,2)'="MI" D SEND
Q
SEND ; Send if procedure is defined
N LRLNOW,LRVX,PXALOOK,PXUCV
I '$G(^TMP("LRPXAPI",$J,"PROCEDURE",1,"PROCEDURE")) G END
I $G(^XTMP("LRPCELOG",0)) D
. F S LRLNOW=$$NOW^XLFDT Q:'$D(^XTMP("LRPCELOG",1,LRLNOW))
. N LRACCX,LRUIDX
. S LRACCX=$G(LRACC),LRUIDX=$G(LRUID)
. M ^XTMP("LRPCELOG",2,LRLNOW)=^TMP("LRPXAPI",$J)
. S ^XTMP("LRPCELOG",2,LRLNOW,0)=LRACCX_U_LRUIDX
S LRVX=$$DATA2PCE^PXAPI(INROOT,LRPKG,SRC,.LRBEVSIT,USR,ERRDIS)
I $D(^XTMP("LRPCELOG",2,+$G(LRLNOW),0)) D
. S $P(^XTMP("LRPCELOG",2,+$G(LRLNOW),0),U,3,4)=LRVX_U_LRBEVSIT
. M ^XTMP("LRPCELOG",2,LRLNOW)=^TMP("LRPXAPI",$J)
I $G(LRBEVSIT) D SVST^LRBEBA3(LRBEVSIT,"PCE",LRODT,LRSN)
END K ^TMP("LRPXAPI",$J),LRBETNUM
Q
;
OPWRK2 ; Outpatient Work Two
K LRBEPTDT
S LRBEDN=0 F S LRBEDN=+$O(LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBEDN)) Q:LRBEDN<1 D OPWRK3
Q
OPWRK3 ;
N JJ
S LRBEPTDT=$G(LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBEDN))
Q:'($L(LRBEPTDT))
I '$P(LRBEPTDT,U,3) D
.S $P(LRBEPTDT,U,3)=LRDBEDGX
.S JJ=$O(^TMP("LRPXAPI",$J,"DX/PL",99),-1)+1
.S ^TMP("LRPXAPI",$J,"DX/PL",JJ,"DIAGNOSIS")=LRDBEDGX
.I JJ=1 S ^TMP("LRPXAPI",$J,"DX/PL",JJ,"PRIMARY")=1
.E S ^TMP("LRPXAPI",$J,"DX/PL",JJ,"PRIMARY")=0
S LRBETNUM=$G(LRBETNUM)+1,LRBEIEN=LRSN_","_LRODT_","
I $P(LRBEPTDT,U,1)'="" D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"PROCEDURE")=$P(LRBEPTDT,U,1)
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"QTY")=1
I $P(LRBEPTDT,U,2)'="" D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"MODIFIERS",$P(LRBEPTDT,U,2))=""
I $P(LRBEPTDT,U,3)'="" D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS")=$P(LRBEPTDT,U,3)
I $P(LRBEPTDT,U,4)'="" D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 2")=$P(LRBEPTDT,U,4)
I $P(LRBEPTDT,U,5)'="" D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 3")=$P(LRBEPTDT,U,5)
I $P(LRBEPTDT,U,6)'="" D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 4")=$P(LRBEPTDT,U,6)
I $P(LRBEPTDT,U,7)'="" D
. N LRBETM S LRBETM=$P(LRBEPTDT,U,7)
. S LRBETM=$$PCETM(LRBETM)
. S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"EVENT D/T")=LRBETM
I $P(LRBEPTDT,U,8)'="" D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"ENC PROVIDER")=$P(LRBEPTDT,U,8)
I $P(LRBEPTDT,U,9)>0 D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"ORD PROVIDER")=$P(LRBEPTDT,U,9)
I $P(LRBEPTDT,U,10)'="" D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"QTY")=$P(LRBEPTDT,U,10)
I $P(LRBEPTDT,U,12)'="" D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 5")=$P(LRBEPTDT,U,12)
I $P(LRBEPTDT,U,13)'="" D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 6")=$P(LRBEPTDT,U,13)
I $P(LRBEPTDT,U,14)'="" D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 7")=$P(LRBEPTDT,U,14)
I $P(LRBEPTDT,U,15)'="" D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS 8")=$P(LRBEPTDT,U,15)
I $P(LRBEPTDT,U,16)'="" D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"ORD REFERENCE")=$P(LRBEPTDT,U,16)
I LRSWSTAT,($P(LRBETM,".")'<LRSWDATE) D
.S ^TMP("LRPXAPI",$J,"PROCEDURE",LRBETNUM,"DEPARTMENT")=108
I $P(LRBEPTDT,U,20)'="" D
.S ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"QTY")=$P(LRBEPTDT,U,20)
I $G(^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS"))=0 K ^TMP("LRPXAPI",$J,SUB1,LRBETNUM,"DIAGNOSIS")
Q
;
INIT ;Setup PCE variables
S INROOT="^TMP(""LRPXAPI"",$J)"
I '$G(LRPKG) D Q:'$G(LRPKG)
. S X="LAB SERVICE",DIC="^DIC(9.4,",DIC(0)="Z" D ^DIC
. I Y S LRPKG=+Y
S SRC="LAB DATA",USR=DUZ,(LRBETNUM,ERRDIS)=0
K DIC
Q
PCETM(LRBETM) ;Return date/time without seconds
N PCETM
S LRBETM=$G(LRBETM)
Q:'LRBETM LRBETM
S PCETM=$E($P(LRBETM,".",2),1,4)
F Q:($L(PCETM)=4) S PCETM=PCETM_0
I PCETM>2359 S PCETM=2359
I $E(PCETM,3,4)>59 S PCETM=$E(PCETM,1,2)_59
I 'PCETM S PCETM="0001"
S $P(LRBETM,".",2)=PCETM
Q LRBETM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBEBAO 9935 printed Dec 13, 2024@02:10:02 Page 2
LRBEBAO ;DALOI/JAH/FHS - ORDERING AND RESULTING FOR OUTPATIENTS ;8/10/04
+1 ;;5.2;LAB SERVICE;**291,359,352**;Sep 27, 1994;Build 1
+2 ;
+3 ; This routine contains the subroutines that get the diagnosis pointers
+4 ; and indicators at order entry and result verification for outpatient.
+5 ;
+6 ; Reference to EN^DDIOL supported by IA #10142
+7 ; Reference to ^DIC supported by IA #10006
+8 ; Reference to $$GET1^DIQ supported by IA #2056
+9 ; Reference to ^DIR supported by IA #10026
+10 ; Reference to ^ICD9 supported by IA #10082
+11 ; Reference to ^DIC(9.4 supported by IA #10048
+12 ; Reference to ^DIC(81.3 supported by IA #2816
+13 ;
OPORD ; Outpatient Order Entry
+1 ;
+2 ; Input:
+3 ; LRBEDFN - Patient's DFN (#2)
+4 ; LRBESMP - Sample
+5 ; LRBESPC - Specimen
+6 ; LRBETST - Ordered Test
+7 ; LRBEDGX - Pointer to Diagnosis (#80)
+8 ; LRBEAR(LRBEDFN,"DOS") - Date of Service
+9 ; LRBEAR(LRBEDFN,"PAT") - Patient DFN (#2)
+10 ; LRBEAR(LRBEDFN,"POS") - Place of Service
+11 ; LRBEAR(LRBEDFN,"ORDGX") - Ordering or Resulting Diagnosis
+12 ; LRBEAR(LRBEDFN,"USR") - User
+13 ; LRBEAR(LRBEDFN,"ORDPRO") - Ordering Provider
+14 ; LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX)
+15 ; Piece Desc
+16 ; ----- ---------------------------------
+17 ; 1 - Diagnosis
+18 ; 2 - Unused (blank)
+19 ; 3 - Textual Description of Diagnosis
+20 ; 4 - Agent Orange
+21 ; 5 - Ionizing Radiation
+22 ; 6 - Service Connected Indicator
+23 ; 7 - Environmental Contaminamts
+24 ; 8 - MST (Military Sexual Tramua)
+25 ; 9 - Head and Neck Cancer
+26 ; 10 - Combat Veteran
+27 ;
+28 ; Output:
+29 ; LRBEAR1(VISIT,TST,LRBEPOV)=LRBEDGX
+30 ; VISIT - Pointer to VISIT (9000010) file
+31 ; TST - Ordered Test
+32 ; LRBEPOV - Pointer to V POV (#9000010.07) file
+33 ; LRBEDGX - Pointer to Diagnosis (#80)
EN ;
+1 DO INIT
+2 SET SUB1="ENCOUNTER"
SET SUB2="DX/PL"
SET SUB3="PROVIDER"
+3 SET LRBEDFN=""
FOR
SET LRBEDFN=$ORDER(LRBEAR(LRBEDFN))
if LRBEDFN=""
QUIT
Begin DoDot:1
+4 SET LRBETM=$SELECT($PIECE($GET(LRBECDT),".",2):LRBECDT,$GET(LRCDT):LRCDT,1:DT)
+5 SET LRBETM=$$PCETM(LRBETM)
+6 SET ^TMP("LRPXAPI",$JOB,SUB1,1,"ENC D/T")=LRBETM
+7 SET ^TMP("LRPXAPI",$JOB,SUB1,1,"DSS ID")=LROOS
+8 SET ^TMP("LRPXAPI",$JOB,SUB1,1,"HOS LOC")=$GET(LRBEAR(LRBEDFN,"POS"))
+9 SET ^TMP("LRPXAPI",$JOB,SUB1,1,"PATIENT")=$GET(LRBEAR(LRBEDFN,"PAT"))
+10 SET ^TMP("LRPXAPI",$JOB,SUB1,1,"SERVICE CATEGORY")="X"
+11 SET ^TMP("LRPXAPI",$JOB,SUB1,1,"ENCOUNTER TYPE")="A"
+12 SET ^TMP("LRPXAPI",$JOB,SUB3,1,"NAME")=$GET(LRBEAR(LRBEDFN,"ORDPRO"))
+13 SET ^TMP("LRPXAPI",$JOB,SUB3,1,"PRIMARY")=1
+14 IF $GET(LRBEAR(LRBEDFN,"DEL"))
Begin DoDot:2
+15 SET ^TMP("LRPXAPI",$JOB,SUB1,1,"DELETE")=$GET(LRBEAR(LRBEDFN,"DEL"))
End DoDot:2
+16 SET LRBESMP=""
+17 FOR
SET LRBESMP=$ORDER(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP))
if LRBESMP=""
QUIT
Begin DoDot:2
+18 SET LRBESPC=""
+19 FOR
SET LRBESPC=+$ORDER(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC))
if LRBESPC<1
QUIT
Begin DoDot:3
+20 DO OPWRK
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
OPWRK ; More Outpatient Work
+1 NEW X,XX,B,BG,N,DX,LRBEDIA
+2 ;get all primary (n=1) and secondary (n=2) dx
+3 SET LRBETST=""
FOR
SET LRBETST=$ORDER(LRBECPT(LRBETST))
if 'LRBETST
QUIT
Begin DoDot:1
+4 SET LRBETNUM=0
FOR
SET LRBETNUM=$ORDER(LRBECPT(LRBETST,LRBETNUM))
if LRBETNUM<1
QUIT
Begin DoDot:2
+5 SET LRBEDGX=""
+6 FOR
SET LRBEDGX=$ORDER(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX))
if LRBEDGX=""
QUIT
Begin DoDot:3
+7 SET LRBEPTDT=$GET(LRBEAR(LRBEDFN,"LRBEDGX",LRBESMP,LRBESPC,LRBETST,LRBEDGX))
+8 SET N=$SELECT($PIECE(LRBEPTDT,U,12):1,1:2)
SET X=$PIECE(LRBEPTDT,U,4,11)
+9 ;collapse indicators for same dx
+10 SET XX=$GET(DX(N,LRBEDGX))
+11 FOR B=1:1:8
IF $PIECE(XX,U,B)'=1
IF $PIECE(X,U,B)'=""
SET $PIECE(XX,U,B)=$PIECE(X,U,B)
+12 SET DX(N,LRBEDGX)=XX
End DoDot:3
End DoDot:2
End DoDot:1
+13 ;set primary dx in PCE array
+14 SET LRBEDGX=""
+15 FOR
SET LRBEDGX=$ORDER(DX(1,LRBEDGX))
if LRBEDGX=""
QUIT
Begin DoDot:1
+16 SET LRBEDIA=$GET(LRBEDIA)+1
SET XX=DX(1,LRBEDGX)
+17 SET ^TMP("LRPXAPI",$JOB,SUB2,LRBEDIA,"DIAGNOSIS")=LRBEDGX
+18 SET ^TMP("LRPXAPI",$JOB,SUB2,LRBEDIA,"PRIMARY")=1
+19 FOR B=1:1:8
IF $PIECE(XX,U,B)'=""
Begin DoDot:2
+20 SET BG=$$GETT(B)
+21 IF '$GET(^TMP("LRPXAPI",$JOB,SUB2,LRBEDIA,BG))
SET ^TMP("LRPXAPI",$JOB,SUB2,LRBEDIA,BG)=$PIECE(XX,U,B)
+22 ;collapse dx indicators into encounter node
+23 IF '$GET(^TMP("LRPXAPI",$JOB,SUB1,1,$PIECE(BG," ",2)))
SET ^TMP("LRPXAPI",$JOB,SUB1,1,$PIECE(BG," ",2))=$PIECE(XX,U,B)
End DoDot:2
End DoDot:1
+24 ;set secondary dx in PCE array
+25 SET LRBEDGX=""
+26 FOR
SET LRBEDGX=$ORDER(DX(2,LRBEDGX))
if LRBEDGX=""
QUIT
Begin DoDot:1
+27 SET LRBEDIA=$GET(LRBEDIA)+1
SET XX=DX(2,LRBEDGX)
+28 SET ^TMP("LRPXAPI",$JOB,SUB2,LRBEDIA,"DIAGNOSIS")=LRBEDGX
+29 FOR B=1:1:8
IF $PIECE(XX,U,B)'=""
Begin DoDot:2
+30 SET BG=$$GETT(B)
+31 IF '$GET(^TMP("LRPXAPI",$JOB,SUB2,LRBEDIA,BG))
SET ^TMP("LRPXAPI",$JOB,SUB2,LRBEDIA,BG)=$PIECE(XX,U,B)
+32 ;collapse dx indicators into encounter node
+33 IF '$GET(^TMP("LRPXAPI",$JOB,SUB1,1,$PIECE(BG," ",2)))
SET ^TMP("LRPXAPI",$JOB,SUB1,1,$PIECE(BG," ",2))=$PIECE(XX,U,B)
End DoDot:2
End DoDot:1
+34 QUIT
+35 ;
GETT(X) ; Indicators for ^TMP
+1 IF '+X
QUIT ""
+2 QUIT "PL "_$SELECT(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:"")
+3 ;
OPRES(LRBEAR,LRBEAR1,LRODT,LRSN,LRBEVST) ; Outpatient Final Resulting
+1 ; Inputs:
+2 ; LRBEDN - Data Number of Test in #63 field 400
+3 ; LRBEAR(LRBEDFN,"VST") - Patient's Encounter Number #9000010
+4 ; LRBEAR(LRBEDFN,"LRBEDGX",LRBEDN)
+5 ; Piece Desc
+6 ; 1 - Procedure (CPT)
+7 ; 2 - Modifiers (Sub-delimited by "~")
+8 ; 3 - Diagnosis
+9 ; 4 - Diagnosis 2
+10 ; 5 - Diagnosis 3
+11 ; 6 - Diagnosis 4
+12 ; 7 - Event D/T (DOS)
+13 ; 8 - Encounter Provider
+14 ; 9 - Ordering Provider
+15 ; 10 - Quantity (Number of times procedure was performed)
+16 ; 11 - Place of Service
+17 ; Output:
+18 ; LRBEAR1(VISIT,TST,LRBEPOV)=LRBEDGX
+19 ; VISIT - Pointer to VISIT (9000010) file
+20 ; TST - Ordered Test
+21 ; LRBEPOV - Pointer to V POV (#9000010.07) file
+22 ; LRBEDGX - Pointer to Diagnosis (#80)
+23 ;
+24 DO INIT
+25 NEW LRSWSTAT,LRSWDATE
+26 SET LRSWSTAT=$$SWSTAT^IBBAPI
+27 SET LRSWDATE=+$PIECE(LRSWSTAT,U,2)
+28 SET LRSWSTAT=+$PIECE(LRSWSTAT,U)
+29 SET SUB1="PROCEDURE"
+30 IF '$GET(LRDBEDGX)
Begin DoDot:1
+31 NEW LRX
+32 SET (LRDBEDGX,LRX)=0
+33 FOR
SET LRX=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRX))
if LRX<1!($GET(LRDBEDGX))
QUIT
Begin DoDot:2
+34 ;set a default diagnosis and sc/ei indicators
+35 IF $GET(^LRO(69,LRODT,1,LRSN,2,LRX,2,1,0))
SET LRDBEDGX=+^(0)
End DoDot:2
End DoDot:1
+36 SET LRBEDFN=""
FOR
SET LRBEDFN=$ORDER(LRBEAR(LRBEDFN))
if LRBEDFN=""
QUIT
Begin DoDot:1
+37 SET LRI=0
FOR
SET LRI=$ORDER(LRBEAR(LRBEDFN,"LRBEDGX",LRI))
if LRI<1
QUIT
Begin DoDot:2
+38 DO OPWRK2
End DoDot:2
End DoDot:1
+39 ;microbiology results sent to PCE in LRCAPPH1
+40 IF $PIECE($GET(^LRO(68,$GET(LRAA),0)),U,2)'="MI"
DO SEND
+41 QUIT
SEND ; Send if procedure is defined
+1 NEW LRLNOW,LRVX,PXALOOK,PXUCV
+2 IF '$GET(^TMP("LRPXAPI",$JOB,"PROCEDURE",1,"PROCEDURE"))
GOTO END
+3 IF $GET(^XTMP("LRPCELOG",0))
Begin DoDot:1
+4 FOR
SET LRLNOW=$$NOW^XLFDT
if '$DATA(^XTMP("LRPCELOG",1,LRLNOW))
QUIT
+5 NEW LRACCX,LRUIDX
+6 SET LRACCX=$GET(LRACC)
SET LRUIDX=$GET(LRUID)
+7 MERGE ^XTMP("LRPCELOG",2,LRLNOW)=^TMP("LRPXAPI",$JOB)
+8 SET ^XTMP("LRPCELOG",2,LRLNOW,0)=LRACCX_U_LRUIDX
End DoDot:1
+9 SET LRVX=$$DATA2PCE^PXAPI(INROOT,LRPKG,SRC,.LRBEVSIT,USR,ERRDIS)
+10 IF $DATA(^XTMP("LRPCELOG",2,+$GET(LRLNOW),0))
Begin DoDot:1
+11 SET $PIECE(^XTMP("LRPCELOG",2,+$GET(LRLNOW),0),U,3,4)=LRVX_U_LRBEVSIT
+12 MERGE ^XTMP("LRPCELOG",2,LRLNOW)=^TMP("LRPXAPI",$JOB)
End DoDot:1
+13 IF $GET(LRBEVSIT)
DO SVST^LRBEBA3(LRBEVSIT,"PCE",LRODT,LRSN)
END KILL ^TMP("LRPXAPI",$JOB),LRBETNUM
+1 QUIT
+2 ;
OPWRK2 ; Outpatient Work Two
+1 KILL LRBEPTDT
+2 SET LRBEDN=0
FOR
SET LRBEDN=+$ORDER(LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBEDN))
if LRBEDN<1
QUIT
DO OPWRK3
+3 QUIT
OPWRK3 ;
+1 NEW JJ
+2 SET LRBEPTDT=$GET(LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBEDN))
+3 if '($LENGTH(LRBEPTDT))
QUIT
+4 IF '$PIECE(LRBEPTDT,U,3)
Begin DoDot:1
+5 SET $PIECE(LRBEPTDT,U,3)=LRDBEDGX
+6 SET JJ=$ORDER(^TMP("LRPXAPI",$JOB,"DX/PL",99),-1)+1
+7 SET ^TMP("LRPXAPI",$JOB,"DX/PL",JJ,"DIAGNOSIS")=LRDBEDGX
+8 IF JJ=1
SET ^TMP("LRPXAPI",$JOB,"DX/PL",JJ,"PRIMARY")=1
+9 IF '$TEST
SET ^TMP("LRPXAPI",$JOB,"DX/PL",JJ,"PRIMARY")=0
End DoDot:1
+10 SET LRBETNUM=$GET(LRBETNUM)+1
SET LRBEIEN=LRSN_","_LRODT_","
+11 IF $PIECE(LRBEPTDT,U,1)'=""
Begin DoDot:1
+12 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"PROCEDURE")=$PIECE(LRBEPTDT,U,1)
+13 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"QTY")=1
End DoDot:1
+14 IF $PIECE(LRBEPTDT,U,2)'=""
Begin DoDot:1
+15 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"MODIFIERS",$PIECE(LRBEPTDT,U,2))=""
End DoDot:1
+16 IF $PIECE(LRBEPTDT,U,3)'=""
Begin DoDot:1
+17 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"DIAGNOSIS")=$PIECE(LRBEPTDT,U,3)
End DoDot:1
+18 IF $PIECE(LRBEPTDT,U,4)'=""
Begin DoDot:1
+19 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"DIAGNOSIS 2")=$PIECE(LRBEPTDT,U,4)
End DoDot:1
+20 IF $PIECE(LRBEPTDT,U,5)'=""
Begin DoDot:1
+21 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"DIAGNOSIS 3")=$PIECE(LRBEPTDT,U,5)
End DoDot:1
+22 IF $PIECE(LRBEPTDT,U,6)'=""
Begin DoDot:1
+23 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"DIAGNOSIS 4")=$PIECE(LRBEPTDT,U,6)
End DoDot:1
+24 IF $PIECE(LRBEPTDT,U,7)'=""
Begin DoDot:1
+25 NEW LRBETM
SET LRBETM=$PIECE(LRBEPTDT,U,7)
+26 SET LRBETM=$$PCETM(LRBETM)
+27 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"EVENT D/T")=LRBETM
End DoDot:1
+28 IF $PIECE(LRBEPTDT,U,8)'=""
Begin DoDot:1
+29 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"ENC PROVIDER")=$PIECE(LRBEPTDT,U,8)
End DoDot:1
+30 IF $PIECE(LRBEPTDT,U,9)>0
Begin DoDot:1
+31 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"ORD PROVIDER")=$PIECE(LRBEPTDT,U,9)
End DoDot:1
+32 IF $PIECE(LRBEPTDT,U,10)'=""
Begin DoDot:1
+33 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"QTY")=$PIECE(LRBEPTDT,U,10)
End DoDot:1
+34 IF $PIECE(LRBEPTDT,U,12)'=""
Begin DoDot:1
+35 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"DIAGNOSIS 5")=$PIECE(LRBEPTDT,U,12)
End DoDot:1
+36 IF $PIECE(LRBEPTDT,U,13)'=""
Begin DoDot:1
+37 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"DIAGNOSIS 6")=$PIECE(LRBEPTDT,U,13)
End DoDot:1
+38 IF $PIECE(LRBEPTDT,U,14)'=""
Begin DoDot:1
+39 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"DIAGNOSIS 7")=$PIECE(LRBEPTDT,U,14)
End DoDot:1
+40 IF $PIECE(LRBEPTDT,U,15)'=""
Begin DoDot:1
+41 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"DIAGNOSIS 8")=$PIECE(LRBEPTDT,U,15)
End DoDot:1
+42 IF $PIECE(LRBEPTDT,U,16)'=""
Begin DoDot:1
+43 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"ORD REFERENCE")=$PIECE(LRBEPTDT,U,16)
End DoDot:1
+44 IF LRSWSTAT
IF ($PIECE(LRBETM,".")'<LRSWDATE)
Begin DoDot:1
+45 SET ^TMP("LRPXAPI",$JOB,"PROCEDURE",LRBETNUM,"DEPARTMENT")=108
End DoDot:1
+46 IF $PIECE(LRBEPTDT,U,20)'=""
Begin DoDot:1
+47 SET ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"QTY")=$PIECE(LRBEPTDT,U,20)
End DoDot:1
+48 IF $GET(^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"DIAGNOSIS"))=0
KILL ^TMP("LRPXAPI",$JOB,SUB1,LRBETNUM,"DIAGNOSIS")
+49 QUIT
+50 ;
INIT ;Setup PCE variables
+1 SET INROOT="^TMP(""LRPXAPI"",$J)"
+2 IF '$GET(LRPKG)
Begin DoDot:1
+3 SET X="LAB SERVICE"
SET DIC="^DIC(9.4,"
SET DIC(0)="Z"
DO ^DIC
+4 IF Y
SET LRPKG=+Y
End DoDot:1
if '$GET(LRPKG)
QUIT
+5 SET SRC="LAB DATA"
SET USR=DUZ
SET (LRBETNUM,ERRDIS)=0
+6 KILL DIC
+7 QUIT
PCETM(LRBETM) ;Return date/time without seconds
+1 NEW PCETM
+2 SET LRBETM=$GET(LRBETM)
+3 if 'LRBETM
QUIT LRBETM
+4 SET PCETM=$EXTRACT($PIECE(LRBETM,".",2),1,4)
+5 FOR
if ($LENGTH(PCETM)=4)
QUIT
SET PCETM=PCETM_0
+6 IF PCETM>2359
SET PCETM=2359
+7 IF $EXTRACT(PCETM,3,4)>59
SET PCETM=$EXTRACT(PCETM,1,2)_59
+8 IF 'PCETM
SET PCETM="0001"
+9 SET $PIECE(LRBETM,".",2)=PCETM
+10 QUIT LRBETM
