LR7OAPKM ;DSS/FHS - INBOUND CPRS MESSAGE HANDLER ;May 13, 2022@10:40:38
;;5.2;LAB SERVICE;**462,553**;Sep 27, 1994;Build 21
Q
AP1(MSG,LRAP1) ;Entry point to store CPRS AP orders messages
; CALL FROM LR7OF0
;In put
; MSG=CPRS HL7 ORDER MESSAGE ARRAY
; ^XTMP("LRAP1",1,IEN.01)=ORIFN^LRDFN
; ^XTMP("LRAP1",1,IEN.02)="AP1"|ORIFN||TEST SUBSCRIPT|||AP Screen IEN_"-"_TEST NAME
; MERGE MSG INTO ^XTMP("LRAP1",1,IEN,1...) USED FOR TROBLE SHOOTING
; +AP Screen IEN pointer to ^LAB(69.71
;
;TASKAP1^LR7OAPKM Stores the CPRS order message data into ^LRO(69,
;
N LRCNT
L +^XTMP("LRAP1"):DILOCKTM
D:'$G(^XTMP("LRAP1",0)) SETUP0 ;Setup ^XTMP("LRAP1")
S LRCNT=+$G(^XTMP("LRAP1",1,0))+1,$P(^XTMP("LRAP1",1,0),U)=LRCNT
L -^XTMP("LRAP1")
S ^XTMP("LRAP1",1,LRCNT,.01)=$G(ORIFN)_U_$G(LRDFN)
S ^XTMP("LRAP1",1,LRCNT,.02)=LRAP1
S ^XTMP("LRAP1","B",+$G(ORIFN),LRCNT)=$$FMTE^XLFDT($$NOW^XLFDT,2)
S ^XTMP("LRAP1","C",+$G(LRDFN),LRCNT)=$$FMTE^XLFDT($$NOW^XLFDT,2)
M ^XTMP("LRAP1",1,LRCNT)=MSG
D AP1LOAD
S $P(^XTMP("LRAP1",0),U)=$$FMADD^XLFDT(DT,180)
Q
;
AP1LOAD ;Call ZTLOAD with LRCNT value
N ZTIO,ZTRTN,ZTDTH,ZTDESC,ZTSAVE
S ZTSAVE("ORIFN")="",ZTSAVE("LRAP1")="",ZTSAVE("DUZ*")=""
S ZTSAVE("LRCNT")="",ZTIO="",ZTDTH=$H,ZTDESC="LR PROCESS CPRS AP ORDER MESSAGE"
S ZTRTN="TASKAP1^LR7OAPKM"
D ^%ZTLOAD
Q
TASKAP1 ;Entry point for TASK
;Pass LRCNT from ^XTMP("LRAP1",
;
K ^TMP("LRAOE",$J)
N DATA,IEN,IENX,IENXX,ID,FDA,LRCOM,LRCOL,LRCOLROOT,LRDFN,LRFIELD,LRFILE
N LRDFN,LRGLOB,LRHEAD,LRDUZ
N LRID,LRJ,LRODT,LRORD,LRQS,LRREF,LRSAMP,LRSCR
N LRSN,LRSP,LRSPCOM,LRSPDATA,LRSPROOT,LRXSS,LRTXT,VAL,X,Y,LRSPCOMROOT,TMP
S:$G(LRCNT) $P(^XTMP("LRAP1",1,0),U,2)=LRCNT
S ORIFN=$P(LRAP1,"|",2),LRXSS=$P(LRAP1,"|",4),LRSCR=$P(LRAP1,"|",7),LRJ=$J
I LRSCR'="" S LRSCR=$O(^LAB(69.71,"B",LRSCR,0))
M LRDUZ=DUZ
S LRREF=$$GET1^DIQ(100,ORIFN_",",33,"I","","ERR")
S LRORD=+LRREF,LRODT=$P(LRREF,";",2),LRSN=$P(LRREF,";",3)
D GETSPEC(ORIFN,.LRSPDATA)
D APSP69(LRODT,LRSN,.LRSPDATA)
S VAL=$$ID(ORIFN)
Q:'$G(VAL)
D LOADIAG(LRODT,LRSN,.TMP)
;
S:$G(LRCNT) $P(^XTMP("LRAP1",1,0),U,3)=LRCNT
;
;
PURGE ;Purge old entries - keep the last 300 entries in the file
;^XTMP("LRAP1",1,0)=NEXT MESSAGE#*MESSAGE # BEING PROCESSED^LAST MESSAGE PROCESSED
; If there are no errors - all three fields should be the same.
;^XTMP("LRAP1",1,IEN,.01)=ORIFN^LRDFN
N IEN,VAL
S IEN=+($P($G(^XTMP("LRAP1",1,0)),U,3)-300) I IEN>1 D
. F IEN=IEN:1:(LRCNT-300) I $G(^XTMP("LRAP1",1,IEN,.01)) S VAL=^(.01) D
. . K ^XTMP("LRAP1","B",+VAL,IEN)
. . K ^XTMP("LRAP1","C",$P(VAL,U,2),IEN)
. . K ^XTMP("LRAP1",1,IEN)
K ORIFN,LRAP1,LRCNT
S:$D(ZTQUEUED) ZTREQ="@"
Q
GETSPEC(ORIFN,RET) ;Retrieve Spec Description/Specimen/Sample
;IN = CPRS ORIFN # ^OR(100,ORIFN
;RET = Return array ID
;OUT = RET(INSTANCE,"NAME")=VALUE
;
N IEN,LRX,INST,VAL,VAL1,X,Y
S (VAL,RET)="",INST=1
I '$G(^OR(100,ORIFN,.1,1,0)) S RET=0 Q RET
;Specimen Description
S IEN=0 F S IEN=$O(^OR(100,ORIFN,4.5,"ID","SPECDESC",IEN)) Q:IEN<1 D
. S VAL=^OR(100,ORIFN,4.5,IEN,0),INST=$P(VAL,U,3),VAL1=^(1)
. S LRX(INST,"DES")=VAL1
S IEN(1)=0 F S IEN(1)=$O(^OR(100,ORIFN,4.5,"ID","SPECIMEN",IEN(1))) Q:IEN(1)<1 D
. S VAL=^OR(100,ORIFN,4.5,IEN(1),0),INST=$P(VAL,U,3),VAL(1)=^(1)
. S LRX(INST,"SPEC")=VAL(1)
S IEN(2)=0 F S IEN(2)=$O(^OR(100,ORIFN,4.5,"ID","SAMPLE",IEN(2))) Q:IEN(2)<1 D
. S VAL=^OR(100,ORIFN,4.5,IEN(2),0),INST=$P(VAL,U,3),VAL1=^(1)
. S LRX(INST,"SAM")=VAL1
M RET=LRX
Q
ZAPLOOK(LRAOE) ; Pointer Lookup into a multiple
K DIC,DA,Y,X
S DIC="^LAB(69.71,"_LRAOE_",4,",DA=LRAOE,DA(1)=21661
S DIC(0)="AQEZNM" D ^DIC
Q
DD ;Get the Data Dictionary values
S LRTXT="" F S LRTXT=$O(LRID(LRTXT)) Q:LRTXT="" D
. S IENX=$O(^LAB(69.71,LRSCR,4,"B",LRTXT,0))
. S LRID(LRTXT)=^LAB(69.71,LRSCR,4,IENX,0)
Q
ID(ORIFN) ;This is the entry point to extract CPRS user response for at CPRS AP Window
;INPUT ORIFN=Pointer to ^OR(100,ORIFN
; LRSCR=Pointer to ^LAB(69.71,LRSCR
;OUTPUT TMP("??"
;Return 1 if valid
; 0^error text
;
K IEN,IENX,ID,XXY,LRID,TMP
I '$G(^OR(100,ORIFN,0)) Q 0_"^File 100 entry does not exist"
;I '$D(^LAB(69.71,LRSCR,0)) Q 0_"^File 69.71,"_LRSCR_" entry does not exist"
S ID=$O(^OR(100,ORIFN,4.5,"ID","CLINHX",0))
I ID M TMP("CL")=^OR(100,ORIFN,4.5,ID,2) K TMP("CL",0)
S ID=$O(^OR(100,ORIFN,4.5,"ID","OPFIND",0))
I ID M TMP("OP")=^OR(100,ORIFN,4.5,ID,2) K TMP("OP",0)
S ID=$O(^OR(100,ORIFN,4.5,"ID","POSTOPDX",0))
I ID M TMP("PO")=^OR(100,ORIFN,4.5,ID,2) K TMP("PO",0)
S ID=$O(^OR(100,ORIFN,4.5,"ID","PREOPDX",0))
I ID M TMP("PR")=^OR(100,ORIFN,4.5,ID,2) K TMP("PR",0)
S ID=$O(^OR(100,ORIFN,4.5,"ID","SPCSUBMIT",0))
I ID S TMP("SUB")=^OR(100,ORIFN,4.5,ID,1)
S ID=$O(^OR(100,ORIFN,4.5,"ID","SURGPROV",0))
I ID S TMP("SURG")=^OR(100,ORIFN,4.5,ID,1)
S ID=$O(^OR(100,ORIFN,4.5,"ID","SURGCASE",0))
I ID S TMP("SURGCASE")=^OR(100,ORIFN,4.5,ID,1)
Q 1
;
ORITEM(ORIFN) ;Return the ^LAB(60,IEN orderable item for an CPRS Order
;
N IEN,VAL,RET,ANS,X,Y
S:ORIFN="" ORIFN=1582
S IEN="1,"_ORIFN_",",RET=0
S VAL=$$GET1^DIQ(100.001,IEN,.01,"I",.ANS,"ERR")
I VAL="" Q RET
I '$D(^ORD(101.43,VAL,"LR")) Q 0
K ERR S VAL(2)=$$GET1^DIQ(101.43,VAL_",",".01","I",.ANS,"ERR")
S RET=$O(^LAB(60,"B",VAL(2),0))
Q +$G(RET)
;
APSP69(LRODT,LRSN,LRSPDATA) ;Load AOE Specimen/Sample into ^LRO(69,DT,1,LRSN,
; INPUT SPDATA(X)=LRSP^LRCOL
;
69 ; Load LRAPDATA(INSTANCE,"NAME") into ^LRO(69,LRODT,1,LRSN
;
N FDA,IEN,IENX,ERR,ERR1,ERR2,WPIEN68,NODE,ANS,ANSY,LRSP,LRCOL
N LRJ,LRNODE
;
;S LRREF=$$GET1^DIQ(100,ORIFN_",",33,"I","","ERR")
;S LRORD=+LRREF,LRODT=$P(LRREF,";",2),LRSN=$P(LRREF,";",3)
S IEN="+1,1,"_LRSN_","_LRODT_",",LRJ=$J
S IENX=0 F S IENX=$O(LRSPDATA(IENX)) Q:IENX<1 D
. S LRSPCOM=LRSPDATA(IENX,"DES")
. S LRSP=LRSPDATA(IENX,"SPEC")
. S LRSAMP=LRSPDATA(IENX,"SAM")
. K FDA,ERR1,ANS
. S FDA(2,69.221661,IEN,.01)=LRSPCOM ;Specimen Description
. S FDA(2,69.221661,IEN,.06)=LRSP ;Specimen ^LAB(61,LRSP
. S FDA(2,69.221661,IEN,.07)=LRSAMP ; Collection Sample ^LAB(62,LRCOL
. D UPDATE^DIE("KS","FDA(2)","","ERR1")
. I $D(ERR1) W !,IENX_" &&&"
Q
;
LOOK(LRTST,LRSPEC,RET) ;Find CPRS SCREEN pointer
; CALLED FROM ORMBLDLR
; LROUT(TEST,AP)=CPRS Screen #
;AP = Pointer to ^LAB(69.71
;LRTST=POINTER TO ^LAB(60,
;LRSPEC= POINTER TO ^LAB(61, Only required for non-panel test
;RET = values returned in the variable. If not pasted values return in the VAL(#) Array
;OUTPUT
;Look at the test level defined CPRS Screen first
;If no test level defined CPRS Screen -
; then look at the test-specimen level assigned CPRS Screen.
;RET(AP#)="" Where AP# = Pointer to ^LAB(69.71 file
;RET="" If no AOE screens defined (null result)
N IEN,IENX,VAL
K RET S RET="",(IENX,IEN)=0,VAL=""
I '$D(^LAB(60,+$G(LRTST),0)) S RET="" Q 0
;Look for panel test CPRS Screen
I $P(^LAB(60,+$G(LRTST),0),U,5)="" D M RET=VAL Q IENX
. F S IEN=$O(^LAB(60,"AV1",+$G(LRTST),IEN)) Q:IEN<1 D
. . S VAL(IEN)=$P(^LAB(69.71,IEN,0),U),IENX=1
;Look in the specimen mulitple
I '$G(IENX) F S IEN=$O(^LAB(60,+$G(LRTST),1,+$G(LRSPEC),21661,"B",IEN)) Q:IEN<1 D
. S VAL(IEN)=$P(^LAB(69.71,IEN,0),U),IENX=1
M RET=VAL
Q IENX
;
;
LOADIAG(LRODT,LRSN,LRDATA) ;Load CPRS Dialog into ^LRO(69
K ERR,FDA
S IEN=LRSN_","_LRODT_","
I $O(TMP("CL",0)) D WP^DIE(69.01,IEN,21661.813,"","TMP(""CL"")","ERR") ;CLINICHX
I $O(TMP("PR",0)) D WP^DIE(69.01,IEN,21661.814,"","TMP(""PR"")","ERR") ;PRE-OPERATIVE
I $O(TMP("OP",0)) D WP^DIE(69.01,IEN,21661.815,"","TMP(""OP"")","ERR") ;OPERATIVE FINDSSSSS
I $O(TMP("PO",0)) D WP^DIE(69.01,IEN,21661.816,"","TMP(""PO"")","ERR") ;POST-OP
S:$G(TMP("SUB"))'="" FDA(2,69.01,IEN,21661.811)=TMP("SUB") ;SUBMITTER
S FDA(2,69.01,IEN,21661.71)="["_LRXSS_"]" ;Accession Ares subscript
S FDA(2,69.01,IEN,21661.72)=LRSCR ;CPRS Screen IEN pointer
I $G(TMP("SURG")) S FDA(2,69.01,IEN,21661.73)=TMP("SURG") ;SURGEON/PROVIDER
;I $G(TMP("SURGCASE")) S FDA(2,69.01,IEN,21661.74)=TMP("SURGCASE") ;SURGERY CASE #
D UPDATE^DIE("KS","FDA(2)","","ERR")
Q
;
DIAG(LRORD,LRSN) ;Retrieve CPRS ORDER DIAGNOSIS DATA FROM ^LRO(69,LRODT,1,LRSN
;IN = CPRS ORIFN # ^OR(100,ORIFN
;RET = Return array ID
;OUT = RET Array
;
BH ;
K ANS,X,Y,ERR,FIL,FLD
S RET="",FIL=69.01,FLD=21661.813,IEN=LRSN_","_LRORD_","
S X=$$GET1^DIQ(69.01,IEN,21661.813,"Z","TMP(""CL"")","ERR") ;BRIEF CLINICAL HISTORY
;
PO S X=$$GET1^DIQ(69.01,IEN,21661.814,"Z","TMP(""PR"")","ERR") ; PREOPERATIVE DIAGNOSIS
;
OF S X=$$GET1^DIQ(69.01,IEN,21661.815,"Z","TMP(""OP"")","ERR") ; OPERATIVE FINGINGS
;
PD S X=$$GET1^DIQ(69.01,IEN,21661.816,"Z","TMP(""PO"")","ERR") ; POSTOPERATIVE DIAGNOSIS
;
W !!
Q
ORDATA(ORIFN,LRVAL) ;Get data from CPRS Dialog fields
K ANS,X,Y,ERR,FIL,FLD
S LRVAL="",FIL=100.045,FLD=2
F VAL=9:1:12 S IEN=VAL_","_ORIFN_"," D
. S X=$$GET1^DIQ(100.045,IEN,FLD,"","ANS("_VAL_")","ERR")
M LRVAL=ANS
Q
FILDIA(LRODT,LRSN,FLD,ARRAY) ;File CPRS AP Dialog into ^LRO(69,LRODT,1,LRSN
K ANS,X,Y,ERR,IEN,FDA
S IEN=LRSN_","_LRODT_","
S FIL=69.01 S:'$G(FLD) FLD=21661.813
D WP^DIE(FIL,IEN,FLD,"ARRAY","ERR")
Q
TESTAP1 ;
;Load LRAP1 data ^LRO(69,3151201,1,1,0)
D ^XUP S LRCNT=7,LRAP1="AP1|2827||CY|||124",ORIFN=2827
K ^TMP("LRAP1",$J)
Q
ASKORDER ;
N DIR,DIRUT
W !!
S DIR("A")="Order Number: ",DIR(0)="FOA"
S DIR("?",1)="Enter a whole number for the order number."
S DIR("?")="Enter '^' to Exit."
D ^DIR I $D(DIRUT) W !!,"OUT",!
I Y="" Q
W !,Y S LRORD=Y
S LRODT=+$O(^LRO(69,"C",LRORD,0))
S LRSN=+$O(^LRO(69,"C",LRORD,LRODT,0))
I 'LRSN W !!,"INVALID ORDER NUMBER" G ASKORDER
I $D(^LRO(69,LRODT,1,LRSN,0)) S LRDFN=+^(0)
D PT^LRX
W @IOF D ORDER^LROS
Q
SETUP0 ;
Q:$G(^XTMP("LRAP1",0))
S ^XTMP("LRAP1",0)=$$FMADD^XLFDT(DT+180)_U_DT_U_"CPRS AP ORDER MESSAGE LOG"
S ^XTMP("LRAP1",1,0)=10
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OAPKM 9964 printed Nov 22, 2024@17:14:48 Page 2
LR7OAPKM ;DSS/FHS - INBOUND CPRS MESSAGE HANDLER ;May 13, 2022@10:40:38
+1 ;;5.2;LAB SERVICE;**462,553**;Sep 27, 1994;Build 21
+2 QUIT
AP1(MSG,LRAP1) ;Entry point to store CPRS AP orders messages
+1 ; CALL FROM LR7OF0
+2 ;In put
+3 ; MSG=CPRS HL7 ORDER MESSAGE ARRAY
+4 ; ^XTMP("LRAP1",1,IEN.01)=ORIFN^LRDFN
+5 ; ^XTMP("LRAP1",1,IEN.02)="AP1"|ORIFN||TEST SUBSCRIPT|||AP Screen IEN_"-"_TEST NAME
+6 ; MERGE MSG INTO ^XTMP("LRAP1",1,IEN,1...) USED FOR TROBLE SHOOTING
+7 ; +AP Screen IEN pointer to ^LAB(69.71
+8 ;
+9 ;TASKAP1^LR7OAPKM Stores the CPRS order message data into ^LRO(69,
+10 ;
+11 NEW LRCNT
+12 LOCK +^XTMP("LRAP1"):DILOCKTM
+13 ;Setup ^XTMP("LRAP1")
if '$GET(^XTMP("LRAP1",0))
DO SETUP0
+14 SET LRCNT=+$GET(^XTMP("LRAP1",1,0))+1
SET $PIECE(^XTMP("LRAP1",1,0),U)=LRCNT
+15 LOCK -^XTMP("LRAP1")
+16 SET ^XTMP("LRAP1",1,LRCNT,.01)=$GET(ORIFN)_U_$GET(LRDFN)
+17 SET ^XTMP("LRAP1",1,LRCNT,.02)=LRAP1
+18 SET ^XTMP("LRAP1","B",+$GET(ORIFN),LRCNT)=$$FMTE^XLFDT($$NOW^XLFDT,2)
+19 SET ^XTMP("LRAP1","C",+$GET(LRDFN),LRCNT)=$$FMTE^XLFDT($$NOW^XLFDT,2)
+20 MERGE ^XTMP("LRAP1",1,LRCNT)=MSG
+21 DO AP1LOAD
+22 SET $PIECE(^XTMP("LRAP1",0),U)=$$FMADD^XLFDT(DT,180)
+23 QUIT
+24 ;
AP1LOAD ;Call ZTLOAD with LRCNT value
+1 NEW ZTIO,ZTRTN,ZTDTH,ZTDESC,ZTSAVE
+2 SET ZTSAVE("ORIFN")=""
SET ZTSAVE("LRAP1")=""
SET ZTSAVE("DUZ*")=""
+3 SET ZTSAVE("LRCNT")=""
SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTDESC="LR PROCESS CPRS AP ORDER MESSAGE"
+4 SET ZTRTN="TASKAP1^LR7OAPKM"
+5 DO ^%ZTLOAD
+6 QUIT
TASKAP1 ;Entry point for TASK
+1 ;Pass LRCNT from ^XTMP("LRAP1",
+2 ;
+3 KILL ^TMP("LRAOE",$JOB)
+4 NEW DATA,IEN,IENX,IENXX,ID,FDA,LRCOM,LRCOL,LRCOLROOT,LRDFN,LRFIELD,LRFILE
+5 NEW LRDFN,LRGLOB,LRHEAD,LRDUZ
+6 NEW LRID,LRJ,LRODT,LRORD,LRQS,LRREF,LRSAMP,LRSCR
+7 NEW LRSN,LRSP,LRSPCOM,LRSPDATA,LRSPROOT,LRXSS,LRTXT,VAL,X,Y,LRSPCOMROOT,TMP
+8 if $GET(LRCNT)
SET $PIECE(^XTMP("LRAP1",1,0),U,2)=LRCNT
+9 SET ORIFN=$PIECE(LRAP1,"|",2)
SET LRXSS=$PIECE(LRAP1,"|",4)
SET LRSCR=$PIECE(LRAP1,"|",7)
SET LRJ=$JOB
+10 IF LRSCR'=""
SET LRSCR=$ORDER(^LAB(69.71,"B",LRSCR,0))
+11 MERGE LRDUZ=DUZ
+12 SET LRREF=$$GET1^DIQ(100,ORIFN_",",33,"I","","ERR")
+13 SET LRORD=+LRREF
SET LRODT=$PIECE(LRREF,";",2)
SET LRSN=$PIECE(LRREF,";",3)
+14 DO GETSPEC(ORIFN,.LRSPDATA)
+15 DO APSP69(LRODT,LRSN,.LRSPDATA)
+16 SET VAL=$$ID(ORIFN)
+17 if '$GET(VAL)
QUIT
+18 DO LOADIAG(LRODT,LRSN,.TMP)
+19 ;
+20 if $GET(LRCNT)
SET $PIECE(^XTMP("LRAP1",1,0),U,3)=LRCNT
+21 ;
+22 ;
PURGE ;Purge old entries - keep the last 300 entries in the file
+1 ;^XTMP("LRAP1",1,0)=NEXT MESSAGE#*MESSAGE # BEING PROCESSED^LAST MESSAGE PROCESSED
+2 ; If there are no errors - all three fields should be the same.
+3 ;^XTMP("LRAP1",1,IEN,.01)=ORIFN^LRDFN
+4 NEW IEN,VAL
+5 SET IEN=+($PIECE($GET(^XTMP("LRAP1",1,0)),U,3)-300)
IF IEN>1
Begin DoDot:1
+6 FOR IEN=IEN:1:(LRCNT-300)
IF $GET(^XTMP("LRAP1",1,IEN,.01))
SET VAL=^(.01)
Begin DoDot:2
+7 KILL ^XTMP("LRAP1","B",+VAL,IEN)
+8 KILL ^XTMP("LRAP1","C",$PIECE(VAL,U,2),IEN)
+9 KILL ^XTMP("LRAP1",1,IEN)
End DoDot:2
End DoDot:1
+10 KILL ORIFN,LRAP1,LRCNT
+11 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+12 QUIT
GETSPEC(ORIFN,RET) ;Retrieve Spec Description/Specimen/Sample
+1 ;IN = CPRS ORIFN # ^OR(100,ORIFN
+2 ;RET = Return array ID
+3 ;OUT = RET(INSTANCE,"NAME")=VALUE
+4 ;
+5 NEW IEN,LRX,INST,VAL,VAL1,X,Y
+6 SET (VAL,RET)=""
SET INST=1
+7 IF '$GET(^OR(100,ORIFN,.1,1,0))
SET RET=0
QUIT RET
+8 ;Specimen Description
+9 SET IEN=0
FOR
SET IEN=$ORDER(^OR(100,ORIFN,4.5,"ID","SPECDESC",IEN))
if IEN<1
QUIT
Begin DoDot:1
+10 SET VAL=^OR(100,ORIFN,4.5,IEN,0)
SET INST=$PIECE(VAL,U,3)
SET VAL1=^(1)
+11 SET LRX(INST,"DES")=VAL1
End DoDot:1
+12 SET IEN(1)=0
FOR
SET IEN(1)=$ORDER(^OR(100,ORIFN,4.5,"ID","SPECIMEN",IEN(1)))
if IEN(1)<1
QUIT
Begin DoDot:1
+13 SET VAL=^OR(100,ORIFN,4.5,IEN(1),0)
SET INST=$PIECE(VAL,U,3)
SET VAL(1)=^(1)
+14 SET LRX(INST,"SPEC")=VAL(1)
End DoDot:1
+15 SET IEN(2)=0
FOR
SET IEN(2)=$ORDER(^OR(100,ORIFN,4.5,"ID","SAMPLE",IEN(2)))
if IEN(2)<1
QUIT
Begin DoDot:1
+16 SET VAL=^OR(100,ORIFN,4.5,IEN(2),0)
SET INST=$PIECE(VAL,U,3)
SET VAL1=^(1)
+17 SET LRX(INST,"SAM")=VAL1
End DoDot:1
+18 MERGE RET=LRX
+19 QUIT
ZAPLOOK(LRAOE) ; Pointer Lookup into a multiple
+1 KILL DIC,DA,Y,X
+2 SET DIC="^LAB(69.71,"_LRAOE_",4,"
SET DA=LRAOE
SET DA(1)=21661
+3 SET DIC(0)="AQEZNM"
DO ^DIC
+4 QUIT
DD ;Get the Data Dictionary values
+1 SET LRTXT=""
FOR
SET LRTXT=$ORDER(LRID(LRTXT))
if LRTXT=""
QUIT
Begin DoDot:1
+2 SET IENX=$ORDER(^LAB(69.71,LRSCR,4,"B",LRTXT,0))
+3 SET LRID(LRTXT)=^LAB(69.71,LRSCR,4,IENX,0)
End DoDot:1
+4 QUIT
ID(ORIFN) ;This is the entry point to extract CPRS user response for at CPRS AP Window
+1 ;INPUT ORIFN=Pointer to ^OR(100,ORIFN
+2 ; LRSCR=Pointer to ^LAB(69.71,LRSCR
+3 ;OUTPUT TMP("??"
+4 ;Return 1 if valid
+5 ; 0^error text
+6 ;
+7 KILL IEN,IENX,ID,XXY,LRID,TMP
+8 IF '$GET(^OR(100,ORIFN,0))
QUIT 0_"^File 100 entry does not exist"
+9 ;I '$D(^LAB(69.71,LRSCR,0)) Q 0_"^File 69.71,"_LRSCR_" entry does not exist"
+10 SET ID=$ORDER(^OR(100,ORIFN,4.5,"ID","CLINHX",0))
+11 IF ID
MERGE TMP("CL")=^OR(100,ORIFN,4.5,ID,2)
KILL TMP("CL",0)
+12 SET ID=$ORDER(^OR(100,ORIFN,4.5,"ID","OPFIND",0))
+13 IF ID
MERGE TMP("OP")=^OR(100,ORIFN,4.5,ID,2)
KILL TMP("OP",0)
+14 SET ID=$ORDER(^OR(100,ORIFN,4.5,"ID","POSTOPDX",0))
+15 IF ID
MERGE TMP("PO")=^OR(100,ORIFN,4.5,ID,2)
KILL TMP("PO",0)
+16 SET ID=$ORDER(^OR(100,ORIFN,4.5,"ID","PREOPDX",0))
+17 IF ID
MERGE TMP("PR")=^OR(100,ORIFN,4.5,ID,2)
KILL TMP("PR",0)
+18 SET ID=$ORDER(^OR(100,ORIFN,4.5,"ID","SPCSUBMIT",0))
+19 IF ID
SET TMP("SUB")=^OR(100,ORIFN,4.5,ID,1)
+20 SET ID=$ORDER(^OR(100,ORIFN,4.5,"ID","SURGPROV",0))
+21 IF ID
SET TMP("SURG")=^OR(100,ORIFN,4.5,ID,1)
+22 SET ID=$ORDER(^OR(100,ORIFN,4.5,"ID","SURGCASE",0))
+23 IF ID
SET TMP("SURGCASE")=^OR(100,ORIFN,4.5,ID,1)
+24 QUIT 1
+25 ;
ORITEM(ORIFN) ;Return the ^LAB(60,IEN orderable item for an CPRS Order
+1 ;
+2 NEW IEN,VAL,RET,ANS,X,Y
+3 if ORIFN=""
SET ORIFN=1582
+4 SET IEN="1,"_ORIFN_","
SET RET=0
+5 SET VAL=$$GET1^DIQ(100.001,IEN,.01,"I",.ANS,"ERR")
+6 IF VAL=""
QUIT RET
+7 IF '$DATA(^ORD(101.43,VAL,"LR"))
QUIT 0
+8 KILL ERR
SET VAL(2)=$$GET1^DIQ(101.43,VAL_",",".01","I",.ANS,"ERR")
+9 SET RET=$ORDER(^LAB(60,"B",VAL(2),0))
+10 QUIT +$GET(RET)
+11 ;
APSP69(LRODT,LRSN,LRSPDATA) ;Load AOE Specimen/Sample into ^LRO(69,DT,1,LRSN,
+1 ; INPUT SPDATA(X)=LRSP^LRCOL
+2 ;
69 ; Load LRAPDATA(INSTANCE,"NAME") into ^LRO(69,LRODT,1,LRSN
+1 ;
+2 NEW FDA,IEN,IENX,ERR,ERR1,ERR2,WPIEN68,NODE,ANS,ANSY,LRSP,LRCOL
+3 NEW LRJ,LRNODE
+4 ;
+5 ;S LRREF=$$GET1^DIQ(100,ORIFN_",",33,"I","","ERR")
+6 ;S LRORD=+LRREF,LRODT=$P(LRREF,";",2),LRSN=$P(LRREF,";",3)
+7 SET IEN="+1,1,"_LRSN_","_LRODT_","
SET LRJ=$JOB
+8 SET IENX=0
FOR
SET IENX=$ORDER(LRSPDATA(IENX))
if IENX<1
QUIT
Begin DoDot:1
+9 SET LRSPCOM=LRSPDATA(IENX,"DES")
+10 SET LRSP=LRSPDATA(IENX,"SPEC")
+11 SET LRSAMP=LRSPDATA(IENX,"SAM")
+12 KILL FDA,ERR1,ANS
+13 ;Specimen Description
SET FDA(2,69.221661,IEN,.01)=LRSPCOM
+14 ;Specimen ^LAB(61,LRSP
SET FDA(2,69.221661,IEN,.06)=LRSP
+15 ; Collection Sample ^LAB(62,LRCOL
SET FDA(2,69.221661,IEN,.07)=LRSAMP
+16 DO UPDATE^DIE("KS","FDA(2)","","ERR1")
+17 IF $DATA(ERR1)
WRITE !,IENX_" &&&"
End DoDot:1
+18 QUIT
+19 ;
LOOK(LRTST,LRSPEC,RET) ;Find CPRS SCREEN pointer
+1 ; CALLED FROM ORMBLDLR
+2 ; LROUT(TEST,AP)=CPRS Screen #
+3 ;AP = Pointer to ^LAB(69.71
+4 ;LRTST=POINTER TO ^LAB(60,
+5 ;LRSPEC= POINTER TO ^LAB(61, Only required for non-panel test
+6 ;RET = values returned in the variable. If not pasted values return in the VAL(#) Array
+7 ;OUTPUT
+8 ;Look at the test level defined CPRS Screen first
+9 ;If no test level defined CPRS Screen -
+10 ; then look at the test-specimen level assigned CPRS Screen.
+11 ;RET(AP#)="" Where AP# = Pointer to ^LAB(69.71 file
+12 ;RET="" If no AOE screens defined (null result)
+13 NEW IEN,IENX,VAL
+14 KILL RET
SET RET=""
SET (IENX,IEN)=0
SET VAL=""
+15 IF '$DATA(^LAB(60,+$GET(LRTST),0))
SET RET=""
QUIT 0
+16 ;Look for panel test CPRS Screen
+17 IF $PIECE(^LAB(60,+$GET(LRTST),0),U,5)=""
Begin DoDot:1
+18 FOR
SET IEN=$ORDER(^LAB(60,"AV1",+$GET(LRTST),IEN))
if IEN<1
QUIT
Begin DoDot:2
+19 SET VAL(IEN)=$PIECE(^LAB(69.71,IEN,0),U)
SET IENX=1
End DoDot:2
End DoDot:1
MERGE RET=VAL
QUIT IENX
+20 ;Look in the specimen mulitple
+21 IF '$GET(IENX)
FOR
SET IEN=$ORDER(^LAB(60,+$GET(LRTST),1,+$GET(LRSPEC),21661,"B",IEN))
if IEN<1
QUIT
Begin DoDot:1
+22 SET VAL(IEN)=$PIECE(^LAB(69.71,IEN,0),U)
SET IENX=1
End DoDot:1
+23 MERGE RET=VAL
+24 QUIT IENX
+25 ;
+26 ;
LOADIAG(LRODT,LRSN,LRDATA) ;Load CPRS Dialog into ^LRO(69
+1 KILL ERR,FDA
+2 SET IEN=LRSN_","_LRODT_","
+3 ;CLINICHX
IF $ORDER(TMP("CL",0))
DO WP^DIE(69.01,IEN,21661.813,"","TMP(""CL"")","ERR")
+4 ;PRE-OPERATIVE
IF $ORDER(TMP("PR",0))
DO WP^DIE(69.01,IEN,21661.814,"","TMP(""PR"")","ERR")
+5 ;OPERATIVE FINDSSSSS
IF $ORDER(TMP("OP",0))
DO WP^DIE(69.01,IEN,21661.815,"","TMP(""OP"")","ERR")
+6 ;POST-OP
IF $ORDER(TMP("PO",0))
DO WP^DIE(69.01,IEN,21661.816,"","TMP(""PO"")","ERR")
+7 ;SUBMITTER
if $GET(TMP("SUB"))'=""
SET FDA(2,69.01,IEN,21661.811)=TMP("SUB")
+8 ;Accession Ares subscript
SET FDA(2,69.01,IEN,21661.71)="["_LRXSS_"]"
+9 ;CPRS Screen IEN pointer
SET FDA(2,69.01,IEN,21661.72)=LRSCR
+10 ;SURGEON/PROVIDER
IF $GET(TMP("SURG"))
SET FDA(2,69.01,IEN,21661.73)=TMP("SURG")
+11 ;I $G(TMP("SURGCASE")) S FDA(2,69.01,IEN,21661.74)=TMP("SURGCASE") ;SURGERY CASE #
+12 DO UPDATE^DIE("KS","FDA(2)","","ERR")
+13 QUIT
+14 ;
DIAG(LRORD,LRSN) ;Retrieve CPRS ORDER DIAGNOSIS DATA FROM ^LRO(69,LRODT,1,LRSN
+1 ;IN = CPRS ORIFN # ^OR(100,ORIFN
+2 ;RET = Return array ID
+3 ;OUT = RET Array
+4 ;
BH ;
+1 KILL ANS,X,Y,ERR,FIL,FLD
+2 SET RET=""
SET FIL=69.01
SET FLD=21661.813
SET IEN=LRSN_","_LRORD_","
+3 ;BRIEF CLINICAL HISTORY
SET X=$$GET1^DIQ(69.01,IEN,21661.813,"Z","TMP(""CL"")","ERR")
+4 ;
PO ; PREOPERATIVE DIAGNOSIS
SET X=$$GET1^DIQ(69.01,IEN,21661.814,"Z","TMP(""PR"")","ERR")
+1 ;
OF ; OPERATIVE FINGINGS
SET X=$$GET1^DIQ(69.01,IEN,21661.815,"Z","TMP(""OP"")","ERR")
+1 ;
PD ; POSTOPERATIVE DIAGNOSIS
SET X=$$GET1^DIQ(69.01,IEN,21661.816,"Z","TMP(""PO"")","ERR")
+1 ;
+2 WRITE !!
+3 QUIT
ORDATA(ORIFN,LRVAL) ;Get data from CPRS Dialog fields
+1 KILL ANS,X,Y,ERR,FIL,FLD
+2 SET LRVAL=""
SET FIL=100.045
SET FLD=2
+3 FOR VAL=9:1:12
SET IEN=VAL_","_ORIFN_","
Begin DoDot:1
+4 SET X=$$GET1^DIQ(100.045,IEN,FLD,"","ANS("_VAL_")","ERR")
End DoDot:1
+5 MERGE LRVAL=ANS
+6 QUIT
FILDIA(LRODT,LRSN,FLD,ARRAY) ;File CPRS AP Dialog into ^LRO(69,LRODT,1,LRSN
+1 KILL ANS,X,Y,ERR,IEN,FDA
+2 SET IEN=LRSN_","_LRODT_","
+3 SET FIL=69.01
if '$GET(FLD)
SET FLD=21661.813
+4 DO WP^DIE(FIL,IEN,FLD,"ARRAY","ERR")
+5 QUIT
TESTAP1 ;
+1 ;Load LRAP1 data ^LRO(69,3151201,1,1,0)
+2 DO ^XUP
SET LRCNT=7
SET LRAP1="AP1|2827||CY|||124"
SET ORIFN=2827
+3 KILL ^TMP("LRAP1",$JOB)
+4 QUIT
ASKORDER ;
+1 NEW DIR,DIRUT
+2 WRITE !!
+3 SET DIR("A")="Order Number: "
SET DIR(0)="FOA"
+4 SET DIR("?",1)="Enter a whole number for the order number."
+5 SET DIR("?")="Enter '^' to Exit."
+6 DO ^DIR
IF $DATA(DIRUT)
WRITE !!,"OUT",!
+7 IF Y=""
QUIT
+8 WRITE !,Y
SET LRORD=Y
+9 SET LRODT=+$ORDER(^LRO(69,"C",LRORD,0))
+10 SET LRSN=+$ORDER(^LRO(69,"C",LRORD,LRODT,0))
+11 IF 'LRSN
WRITE !!,"INVALID ORDER NUMBER"
GOTO ASKORDER
+12 IF $DATA(^LRO(69,LRODT,1,LRSN,0))
SET LRDFN=+^(0)
+13 DO PT^LRX
+14 WRITE @IOF
DO ORDER^LROS
+15 QUIT
SETUP0 ;
+1 if $GET(^XTMP("LRAP1",0))
QUIT
+2 SET ^XTMP("LRAP1",0)=$$FMADD^XLFDT(DT+180)_U_DT_U_"CPRS AP ORDER MESSAGE LOG"
+3 SET ^XTMP("LRAP1",1,0)=10
+4 QUIT
