Routine: LR7OAPKM

LR7OAPKM ;DSS/FHS - INBOUND CPRS MESSAGE HANDLER ;May 13, 2022@10:40:38

 ;;5.2;LAB SERVICE;**462,553**;Sep 27, 1994;Build 21

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)

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

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="@"

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

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

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)

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_" &&&"

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")

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 !!

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

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")

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)

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

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OAPKM   9964     printed  Apr 23, 2025@18:18:41                                                                                                                                                                                                    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

LR7OAPKM.m