LRAPKLG ;DSS/FHS - MOVE SP DATA FROM SURGICAL RECORD ;09/21/16 10:44
;;5.2;LAB SERVICE;**462**;Sep 27, 1994;Build 44
; Supported calls AI #, 5286,103,3615
EN ;
; Called from MOVE^LRAPKOE
; Call with
; LRDFN - LRSS - LRIDT - LRCDT
Q:$P(^LR(LRDFN,0),U,2)'=2
N A,ANS,CASE,CNT,CNTX,D0,DA,DIC,DIR,DIRUT,DR,DTOUT,DUOUT
N ERR,FDA,FIL,FLD,IEN,LRABORT,LRCASE,LRDIAL,LRDOC,LREDT
N LREND,LRFHDR,LRHDR,LRI,LRIEN,LRLONG,LROK,LROPER,LROPERS
N LROPS,LRPAGE,LRPRAC,LROTHER,LRSCAN,LRRB,LRSCAN
N LRSDATE,LRSDOC,LRSDT,LRSDX
N LRSTAT,LRSTATUS,LRSURGDT,LRSURPHY,LRTN,LRTREA,LRV,LRVAL
N LRWRD,LRX,LRYN,S,STR,VADM,VA,VAL,VAIN,X,Y
EN0 ;
S LROK=0
S:'$G(DFN) DFN=$P(^LR(LRDFN,0),U,3) D PT^LRX
I '$O(^SRF("ADT",DFN,0)) W !,"No Surgery Case for "_PNM Q
S LREDT=9999999.999999-$$FMADD^XLFDT(DT,-7) ; End Date
S LRSDT=9999999.999999-$$NOW^XLFDT ;Start Date
W @IOF,!!,"Checking surgical record for this patient...",!
W PNM," ",$P(VADM(5),U,2)," DOB:",$$FMTE^XLFDT($P(VADM(3),U),5)," SSN:",$P(VADM(2),U,2),!
S CNT=0 F S LRSDT=$O(^SRF("ADT",DFN,LRSDT)) Q:'LRSDT!(LRSDT>LREDT) S LRCASE=0 F S LRCASE=$O(^SRF("ADT",DFN,LRSDT,LRCASE)) Q:'LRCASE D LIST
EN1 ;
;
I CNT=0 W !,"No operations on record in the past 7 days.",! Q
I CNT=1 D Q
. W @IOF
. W !,"Only one operation on record available",! H 3
. S (LRTN,LRCASE)=+LRCASE(1) D DISPLAY(LRCASE)
. I '$G(LROK) D END Q
. I $G(LROK) D STORE^LRAPKLG1(LRDFN,LRSS,LRIDT,.LRHDR)
;
OPT K DIR S DIR("?",1)="Enter the number of the operation associated with the specimen(s)",DIR("?")="or press RETURN to bypass operation selection."
W ! S DIR("A")="Select operation associated with the specimen(s)",DIR(0)="NO^1:"_CNT
D ^DIR I $D(DTOUT)!$D(DUOUT) Q
I +Y S LRTN=+LRCASE(+Y),CNT=+Y
NOOP I '$D(LRTN) W !!,"No operation selected.",! Q
S LRCASE=LRTN
W $$CJ^XLFSTR("Entry from Surgery Case #"_LRTN,IOM),!
DOC S LRDOC=$S($P($G(^SRF(LRTN,"NON")),U)="Y":$P(^("NON"),U,6),1:$P($G(^SRF(LRTN,.1)),U,4))
DISP I $D(LRTN) S LRCASE=LRTN,LRSDATE=$P(^SRF(LRTN,0),U,9) D DISPLAY(LRCASE)
I $G(LROK) D STORE^LRAPKLG1(LRDFN,LRSS,LRIDT,.LRHDR)
I '$G(LROK) D END
Q
LIST ; list cases
W !
S LRSCAN=1 I $P($G(^SRF(LRCASE,.2)),U,10)!$P($G(^SRF(LRCASE,.2)),U,12)!($P($G(^SRF(LRCASE,"NON")),U)="Y") K LRSCAN
I $D(LRSCAN),$D(^SRF(LRCASE,30)),$P(^(30),U) Q
I $D(LRSCAN),$D(^SRF(LRCASE,31)),$P(^(31),U,8) Q
I $D(^SRF(LRCASE,37)),$P(^(37),U) Q
S CNT=+$G(CNT)+1,LRSDATE=$P(^SRF(LRCASE,0),U,9) W !,CNT_". "
S LRSDX=$$FMTE^XLFDT(LRSDATE,"5P")
CASE W "D/T:"_LRSDX_" "
N LRI,LRVAL,LROPS
S LROPER=$P(^SRF(LRCASE,"OP"),U)
I $O(^SRF(LRCASE,13,0)) S LROTHER=0 D
. F S LROTHER=$O(^SRF(LRCASE,13,LROTHER)) Q:'LROTHER D OTHER
S LROPER="Case #"_LRCASE_" >> "_LROPER
D STATUS^LRAPKLG1(LRCASE)
S:$L(LROPER)<65 LROPS(1)=LROPER
I $L(LROPER)>64 S LROPER=LROPER_" " F LRI=1:1 D LOOK Q:LRVAL(1)=""
W ?14,LROPS(1) I $D(LROPS(2)) W !,?14,LROPS(2) I $D(LROPS(3)) W !,?14,LROPS(3) W:$D(LROPS(4)) !,?14,LROPS(4)
S LRCASE(CNT)=LRCASE_U_LRSDX_U_LRSURPHY
Q
OTHER ; Check for other operations
;^DD(130,.42
S LRLONG=1 I $L(LROPER)+$L($P(^SRF(LRCASE,13,LROTHER,0),U))>235 S LRLONG=0,LROTHER=999,LROPERS=" ..."
I LRLONG S LROPERS=$P(^SRF(LRCASE,13,LROTHER,0),U)
S LROPER=LROPER_$S(LROPERS=" ...":LROPERS,1:", "_LROPERS)
Q
LOOK ; parse out procedures
S LROPS(LRI)="" F S LRVAL=$P(LROPER," "),LRVAL(1)=$P(LROPER," ",2,200) Q:LRVAL(1)="" Q:$L(LROPS(LRI))+$L(LRVAL)'<65 S LROPS(LRI)=LROPS(LRI)_LRVAL_" ",LROPER=LRVAL(1)
;
Q
;
DISPLAY(LRCASE) ;Display the Dialog for a Surgery case
;Call with Surgery Case # ^SRF(LRCASE#)
;LRHDR array contains the Surgery Package dialog
;Where "X" = array subscript
;LRHDR(33,X)="Preoperative diagnosis"
;LRHDR(34,X)="Post Opertive Diag"
;LRHDR(38,X)="Operative Finding"
;LRHDR(39,X)="Brief Clinical History" DD(63.08,.013)
N CNT,DIC,DA,DR,S,LRLN,LRPAGE,IEN,LREND,LRSDOC,VAL
S $P(LRLN," ",IOM)=" "
S LRSDOC=$S($P($G(^SRF(LRCASE,"NON")),U)="Y":$P(^("NON"),U,6),1:$P($G(^SRF(LRCASE,.1)),U,4))
S LREND=0
D HDR,PRTHDR
;
S LRHDR(1)=$$FMT(" ===== Above From Surgery Case#: "_LRCASE_" =====",IOM)
S LRHDR(2)=LRLN
S CNT=0
;BRIEF CLINICAL HISTORY:
I $O(^SRF(LRCASE,39,0)) D
. S (CNT,CNTX,IEN)=0,LRHDR=$$FMT(" Brief Clinical History",IOM) D
. . W !,LRHDR," ",!
. . F S IEN=$O(^SRF(LRCASE,39,IEN)) Q:IEN<1!($G(LREND)) S VAL=^(IEN,0) D
. . . S VAL=$$FMT(VAL,IOM)
. . . W VAL,! S (CNTX,CNT)=CNT+1,LRHDR(39,CNT)=VAL
D PAGE
Q:$G(LREND)
I $G(CNTX) D FOOT(39,CNTX)
;
;Pre-Operative Diagnosis
I $P($G(^SRF(LRCASE,33)),U)'="" K CNTX D
. D PAGE Q:LREND
. S LRHDR=$$FMT(" Pre-Operative Diagnosis:",IOM),CNTX=0
. W !,LRHDR,!
. S CNT=1,VAL=$$FMT($P(^SRF(LRCASE,33),U),IOM),LRHDR(33,CNT)=VAL W VAL,!
. D PAGE Q:$G(LREND) S CNTX=CNT
. N IEN
. Q:'$O(^SRF(LRCASE,14,0)) ;Get additional Preop diagnosis
. S LRHDR=$$FMT(" Additional Pre-Operative Diagnosis",IOM) W !,LRHDR,!
. S IEN=0 F S IEN=$O(^SRF(LRCASE,14,IEN)) Q:IEN<1!($G(LREND)) D
. . Q:$P($G(^SRF(LRCASE,14,IEN,0)),U)=""
. . S VAL=$$FMT($P(^SRF(LRCASE,14,IEN,0),U),IOM)
. . S (CNTX,CNT)=CNT+1,LRHDR(33,CNT)=VAL W VAL,!
. . D PAGE
Q:$G(LREND)
I $G(CNTX) D FOOT(33,CNTX)
;Operative findings
S (CNT,CNTX,IEN)=0,LRHDR=$$FMT(" Operative Finding",IOM) I $O(^SRF(LRCASE,38,0)) D
. D PAGE Q:$G(LREND)
. W !,LRHDR," ",!
. D PAGE Q:$G(LREND)
. F S IEN=$O(^SRF(LRCASE,38,IEN)) Q:IEN<1!($G(LREND)) S VAL=^(IEN,0) D
. . S VAL=$$FMT(VAL,IOM)
. . W VAL,! S (CNTX,CNT)=CNT+1,LRHDR(38,CNT)=VAL D PAGE Q:$G(LREND)
I $G(CNTX) D FOOT(38,CNTX)
Q:$G(LREND)
K CNT,CNTX,VAL
;Post Operative Diagnosis
I $P($G(^SRF(LRCASE,34)),U)'="" S CNT=1 D
. S VAL=$$FMT($P(^SRF(LRCASE,34),U),IOM)
. S LRHDR(34,CNT)=VAL
. S LRHDR=$$FMT(" Post Operative Diagnosis",IOM),CNTX=CNT
. D PAGE Q:LREND
. W !,LRHDR,!
. W VAL,!
. N IEN
. S IEN=0 F S IEN=$O(^SRF(LRCASE,15,IEN)) Q:IEN<1!$G(LREND) D
. . Q:$P($G(^SRF(LRCASE,15,IEN,0)),U)=""
. . S VAL=$$FMT($P(^SRF(LRCASE,15,IEN,0),U),IOM)
. . S (CNTX,CNT)=CNT+1,LRHDR(34,CNT)=VAL
. . W VAL,! D PAGE
Q:$G(LREND)
I $G(CNTX) D FOOT(34,CNTX)
D YN("Move this information into Laboratory Patient Record File")
Q
PAGE ;End of page prompt
Q:$Y<(IOSL-2)
S LREND=0
K DTOUT,DUOUT,DIRUT,Y,DIR
S DIR(0)="E" D ^DIR
I Y=0 S LREND=1 Q
I Y=1 D PRTHDR
Q
HDR ;Setup Header information
S LRSURPHY="DR:"_$$GET1^DIQ(200,LRSDOC_",",.01,"ANS","ERR")
S LRSURGDT=$$FMTE^XLFDT($P(^SRF(LRCASE,0),U,9),"1P")_" DOB: "_$$FMTE^XLFDT(DOB,2)
S LRHDR(0)=PNM_" SSN:"_SSN_" CASE# "_LRCASE
S LRHDR(0,1)=" Surgery Date:"_LRSURGDT_" "_LRSURPHY
Q
PRTHDR ; Print report header info
S LRPAGE=$G(LRPAGE)+1
W:'$G(LRFHDR) !!!
W:$G(LRFHDR) @IOF
S LRFHDR=1
W $$CJ^XLFSTR("PG:"_LRPAGE_" "_LRHDR(0),IOM)
W !,$$CJ^XLFSTR(LRHDR(0,1),IOM),!
Q
YN(STR) ;Yes No response
N DTOUT,DUOUT,DIRUT,X,Y,DIR
S LROK=0,LREND=1
S DIR(0)="Y",DIR("A")=STR,DIR("B")="No"
D ^DIR
S:+$G(Y)=1 LROK=1,LREND=0
Q
END ;User Termination Response
W !,$$CJ^XLFSTR("No Surgery Data was transferred",IOM),!
Q
FMT(VAL,IOM) ;Format line to IOM length
Q VAL
W "+" I $L(VAL)>71 Q VAL
I VAL="" S VAL=" "
S VAL=VAL_$E(LRLN,$L(VAL),71)
Q VAL
S LRX=LRX+1,LRHDR(SEG,LRX)=LRHDR(1)
S LRX=LRX+1,LRHDR(SEG,LRX)=LRHDR(2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPKLG 7394 printed Sep 23, 2025@19:43:11 Page 2
LRAPKLG ;DSS/FHS - MOVE SP DATA FROM SURGICAL RECORD ;09/21/16 10:44
+1 ;;5.2;LAB SERVICE;**462**;Sep 27, 1994;Build 44
+2 ; Supported calls AI #, 5286,103,3615
EN ;
+1 ; Called from MOVE^LRAPKOE
+2 ; Call with
+3 ; LRDFN - LRSS - LRIDT - LRCDT
+4 if $PIECE(^LR(LRDFN,0),U,2)'=2
QUIT
+5 NEW A,ANS,CASE,CNT,CNTX,D0,DA,DIC,DIR,DIRUT,DR,DTOUT,DUOUT
+6 NEW ERR,FDA,FIL,FLD,IEN,LRABORT,LRCASE,LRDIAL,LRDOC,LREDT
+7 NEW LREND,LRFHDR,LRHDR,LRI,LRIEN,LRLONG,LROK,LROPER,LROPERS
+8 NEW LROPS,LRPAGE,LRPRAC,LROTHER,LRSCAN,LRRB,LRSCAN
+9 NEW LRSDATE,LRSDOC,LRSDT,LRSDX
+10 NEW LRSTAT,LRSTATUS,LRSURGDT,LRSURPHY,LRTN,LRTREA,LRV,LRVAL
+11 NEW LRWRD,LRX,LRYN,S,STR,VADM,VA,VAL,VAIN,X,Y
EN0 ;
+1 SET LROK=0
+2 if '$GET(DFN)
SET DFN=$PIECE(^LR(LRDFN,0),U,3)
DO PT^LRX
+3 IF '$ORDER(^SRF("ADT",DFN,0))
WRITE !,"No Surgery Case for "_PNM
QUIT
+4 ; End Date
SET LREDT=9999999.999999-$$FMADD^XLFDT(DT,-7)
+5 ;Start Date
SET LRSDT=9999999.999999-$$NOW^XLFDT
+6 WRITE @IOF,!!,"Checking surgical record for this patient...",!
+7 WRITE PNM," ",$PIECE(VADM(5),U,2)," DOB:",$$FMTE^XLFDT($PIECE(VADM(3),U),5)," SSN:",$PIECE(VADM(2),U,2),!
+8 SET CNT=0
FOR
SET LRSDT=$ORDER(^SRF("ADT",DFN,LRSDT))
if 'LRSDT!(LRSDT>LREDT)
QUIT
SET LRCASE=0
FOR
SET LRCASE=$ORDER(^SRF("ADT",DFN,LRSDT,LRCASE))
if 'LRCASE
QUIT
DO LIST
EN1 ;
+1 ;
+2 IF CNT=0
WRITE !,"No operations on record in the past 7 days.",!
QUIT
+3 IF CNT=1
Begin DoDot:1
+4 WRITE @IOF
+5 WRITE !,"Only one operation on record available",!
HANG 3
+6 SET (LRTN,LRCASE)=+LRCASE(1)
DO DISPLAY(LRCASE)
+7 IF '$GET(LROK)
DO END
QUIT
+8 IF $GET(LROK)
DO STORE^LRAPKLG1(LRDFN,LRSS,LRIDT,.LRHDR)
End DoDot:1
QUIT
+9 ;
OPT KILL DIR
SET DIR("?",1)="Enter the number of the operation associated with the specimen(s)"
SET DIR("?")="or press RETURN to bypass operation selection."
+1 WRITE !
SET DIR("A")="Select operation associated with the specimen(s)"
SET DIR(0)="NO^1:"_CNT
+2 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+3 IF +Y
SET LRTN=+LRCASE(+Y)
SET CNT=+Y
NOOP IF '$DATA(LRTN)
WRITE !!,"No operation selected.",!
QUIT
+1 SET LRCASE=LRTN
+2 WRITE $$CJ^XLFSTR("Entry from Surgery Case #"_LRTN,IOM),!
DOC SET LRDOC=$SELECT($PIECE($GET(^SRF(LRTN,"NON")),U)="Y":$PIECE(^("NON"),U,6),1:$PIECE($GET(^SRF(LRTN,.1)),U,4))
DISP IF $DATA(LRTN)
SET LRCASE=LRTN
SET LRSDATE=$PIECE(^SRF(LRTN,0),U,9)
DO DISPLAY(LRCASE)
+1 IF $GET(LROK)
DO STORE^LRAPKLG1(LRDFN,LRSS,LRIDT,.LRHDR)
+2 IF '$GET(LROK)
DO END
+3 QUIT
LIST ; list cases
+1 WRITE !
+2 SET LRSCAN=1
IF $PIECE($GET(^SRF(LRCASE,.2)),U,10)!$PIECE($GET(^SRF(LRCASE,.2)),U,12)!($PIECE($GET(^SRF(LRCASE,"NON")),U)="Y")
KILL LRSCAN
+3 IF $DATA(LRSCAN)
IF $DATA(^SRF(LRCASE,30))
IF $PIECE(^(30),U)
QUIT
+4 IF $DATA(LRSCAN)
IF $DATA(^SRF(LRCASE,31))
IF $PIECE(^(31),U,8)
QUIT
+5 IF $DATA(^SRF(LRCASE,37))
IF $PIECE(^(37),U)
QUIT
+6 SET CNT=+$GET(CNT)+1
SET LRSDATE=$PIECE(^SRF(LRCASE,0),U,9)
WRITE !,CNT_". "
+7 SET LRSDX=$$FMTE^XLFDT(LRSDATE,"5P")
CASE WRITE "D/T:"_LRSDX_" "
+1 NEW LRI,LRVAL,LROPS
+2 SET LROPER=$PIECE(^SRF(LRCASE,"OP"),U)
+3 IF $ORDER(^SRF(LRCASE,13,0))
SET LROTHER=0
Begin DoDot:1
+4 FOR
SET LROTHER=$ORDER(^SRF(LRCASE,13,LROTHER))
if 'LROTHER
QUIT
DO OTHER
End DoDot:1
+5 SET LROPER="Case #"_LRCASE_" >> "_LROPER
+6 DO STATUS^LRAPKLG1(LRCASE)
+7 if $LENGTH(LROPER)<65
SET LROPS(1)=LROPER
+8 IF $LENGTH(LROPER)>64
SET LROPER=LROPER_" "
FOR LRI=1:1
DO LOOK
if LRVAL(1)=""
QUIT
+9 WRITE ?14,LROPS(1)
IF $DATA(LROPS(2))
WRITE !,?14,LROPS(2)
IF $DATA(LROPS(3))
WRITE !,?14,LROPS(3)
if $DATA(LROPS(4))
WRITE !,?14,LROPS(4)
+10 SET LRCASE(CNT)=LRCASE_U_LRSDX_U_LRSURPHY
+11 QUIT
OTHER ; Check for other operations
+1 ;^DD(130,.42
+2 SET LRLONG=1
IF $LENGTH(LROPER)+$LENGTH($PIECE(^SRF(LRCASE,13,LROTHER,0),U))>235
SET LRLONG=0
SET LROTHER=999
SET LROPERS=" ..."
+3 IF LRLONG
SET LROPERS=$PIECE(^SRF(LRCASE,13,LROTHER,0),U)
+4 SET LROPER=LROPER_$SELECT(LROPERS=" ...":LROPERS,1:", "_LROPERS)
+5 QUIT
LOOK ; parse out procedures
+1 SET LROPS(LRI)=""
FOR
SET LRVAL=$PIECE(LROPER," ")
SET LRVAL(1)=$PIECE(LROPER," ",2,200)
if LRVAL(1)=""
QUIT
if $LENGTH(LROPS(LRI))+$LENGTH(LRVAL)'<65
QUIT
SET LROPS(LRI)=LROPS(LRI)_LRVAL_" "
SET LROPER=LRVAL(1)
+2 ;
+3 QUIT
+4 ;
DISPLAY(LRCASE) ;Display the Dialog for a Surgery case
+1 ;Call with Surgery Case # ^SRF(LRCASE#)
+2 ;LRHDR array contains the Surgery Package dialog
+3 ;Where "X" = array subscript
+4 ;LRHDR(33,X)="Preoperative diagnosis"
+5 ;LRHDR(34,X)="Post Opertive Diag"
+6 ;LRHDR(38,X)="Operative Finding"
+7 ;LRHDR(39,X)="Brief Clinical History" DD(63.08,.013)
+8 NEW CNT,DIC,DA,DR,S,LRLN,LRPAGE,IEN,LREND,LRSDOC,VAL
+9 SET $PIECE(LRLN," ",IOM)=" "
+10 SET LRSDOC=$SELECT($PIECE($GET(^SRF(LRCASE,"NON")),U)="Y":$PIECE(^("NON"),U,6),1:$PIECE($GET(^SRF(LRCASE,.1)),U,4))
+11 SET LREND=0
+12 DO HDR
DO PRTHDR
+13 ;
+14 SET LRHDR(1)=$$FMT(" ===== Above From Surgery Case#: "_LRCASE_" =====",IOM)
+15 SET LRHDR(2)=LRLN
+16 SET CNT=0
+17 ;BRIEF CLINICAL HISTORY:
+18 IF $ORDER(^SRF(LRCASE,39,0))
Begin DoDot:1
+19 SET (CNT,CNTX,IEN)=0
SET LRHDR=$$FMT(" Brief Clinical History",IOM)
Begin DoDot:2
+20 WRITE !,LRHDR," ",!
+21 FOR
SET IEN=$ORDER(^SRF(LRCASE,39,IEN))
if IEN<1!($GET(LREND))
QUIT
SET VAL=^(IEN,0)
Begin DoDot:3
+22 SET VAL=$$FMT(VAL,IOM)
+23 WRITE VAL,!
SET (CNTX,CNT)=CNT+1
SET LRHDR(39,CNT)=VAL
End DoDot:3
End DoDot:2
End DoDot:1
+24 DO PAGE
+25 if $GET(LREND)
QUIT
+26 IF $GET(CNTX)
DO FOOT(39,CNTX)
+27 ;
+28 ;Pre-Operative Diagnosis
+29 IF $PIECE($GET(^SRF(LRCASE,33)),U)'=""
KILL CNTX
Begin DoDot:1
+30 DO PAGE
if LREND
QUIT
+31 SET LRHDR=$$FMT(" Pre-Operative Diagnosis:",IOM)
SET CNTX=0
+32 WRITE !,LRHDR,!
+33 SET CNT=1
SET VAL=$$FMT($PIECE(^SRF(LRCASE,33),U),IOM)
SET LRHDR(33,CNT)=VAL
WRITE VAL,!
+34 DO PAGE
if $GET(LREND)
QUIT
SET CNTX=CNT
+35 NEW IEN
+36 ;Get additional Preop diagnosis
if '$ORDER(^SRF(LRCASE,14,0))
QUIT
+37 SET LRHDR=$$FMT(" Additional Pre-Operative Diagnosis",IOM)
WRITE !,LRHDR,!
+38 SET IEN=0
FOR
SET IEN=$ORDER(^SRF(LRCASE,14,IEN))
if IEN<1!($GET(LREND))
QUIT
Begin DoDot:2
+39 if $PIECE($GET(^SRF(LRCASE,14,IEN,0)),U)=""
QUIT
+40 SET VAL=$$FMT($PIECE(^SRF(LRCASE,14,IEN,0),U),IOM)
+41 SET (CNTX,CNT)=CNT+1
SET LRHDR(33,CNT)=VAL
WRITE VAL,!
+42 DO PAGE
End DoDot:2
End DoDot:1
+43 if $GET(LREND)
QUIT
+44 IF $GET(CNTX)
DO FOOT(33,CNTX)
+45 ;Operative findings
+46 SET (CNT,CNTX,IEN)=0
SET LRHDR=$$FMT(" Operative Finding",IOM)
IF $ORDER(^SRF(LRCASE,38,0))
Begin DoDot:1
+47 DO PAGE
if $GET(LREND)
QUIT
+48 WRITE !,LRHDR," ",!
+49 DO PAGE
if $GET(LREND)
QUIT
+50 FOR
SET IEN=$ORDER(^SRF(LRCASE,38,IEN))
if IEN<1!($GET(LREND))
QUIT
SET VAL=^(IEN,0)
Begin DoDot:2
+51 SET VAL=$$FMT(VAL,IOM)
+52 WRITE VAL,!
SET (CNTX,CNT)=CNT+1
SET LRHDR(38,CNT)=VAL
DO PAGE
if $GET(LREND)
QUIT
End DoDot:2
End DoDot:1
+53 IF $GET(CNTX)
DO FOOT(38,CNTX)
+54 if $GET(LREND)
QUIT
+55 KILL CNT,CNTX,VAL
+56 ;Post Operative Diagnosis
+57 IF $PIECE($GET(^SRF(LRCASE,34)),U)'=""
SET CNT=1
Begin DoDot:1
+58 SET VAL=$$FMT($PIECE(^SRF(LRCASE,34),U),IOM)
+59 SET LRHDR(34,CNT)=VAL
+60 SET LRHDR=$$FMT(" Post Operative Diagnosis",IOM)
SET CNTX=CNT
+61 DO PAGE
if LREND
QUIT
+62 WRITE !,LRHDR,!
+63 WRITE VAL,!
+64 NEW IEN
+65 SET IEN=0
FOR
SET IEN=$ORDER(^SRF(LRCASE,15,IEN))
if IEN<1!$GET(LREND)
QUIT
Begin DoDot:2
+66 if $PIECE($GET(^SRF(LRCASE,15,IEN,0)),U)=""
QUIT
+67 SET VAL=$$FMT($PIECE(^SRF(LRCASE,15,IEN,0),U),IOM)
+68 SET (CNTX,CNT)=CNT+1
SET LRHDR(34,CNT)=VAL
+69 WRITE VAL,!
DO PAGE
End DoDot:2
End DoDot:1
+70 if $GET(LREND)
QUIT
+71 IF $GET(CNTX)
DO FOOT(34,CNTX)
+72 DO YN("Move this information into Laboratory Patient Record File")
+73 QUIT
PAGE ;End of page prompt
+1 if $Y<(IOSL-2)
QUIT
+2 SET LREND=0
+3 KILL DTOUT,DUOUT,DIRUT,Y,DIR
+4 SET DIR(0)="E"
DO ^DIR
+5 IF Y=0
SET LREND=1
QUIT
+6 IF Y=1
DO PRTHDR
+7 QUIT
HDR ;Setup Header information
+1 SET LRSURPHY="DR:"_$$GET1^DIQ(200,LRSDOC_",",.01,"ANS","ERR")
+2 SET LRSURGDT=$$FMTE^XLFDT($PIECE(^SRF(LRCASE,0),U,9),"1P")_" DOB: "_$$FMTE^XLFDT(DOB,2)
+3 SET LRHDR(0)=PNM_" SSN:"_SSN_" CASE# "_LRCASE
+4 SET LRHDR(0,1)=" Surgery Date:"_LRSURGDT_" "_LRSURPHY
+5 QUIT
PRTHDR ; Print report header info
+1 SET LRPAGE=$GET(LRPAGE)+1
+2 if '$GET(LRFHDR)
WRITE !!!
+3 if $GET(LRFHDR)
WRITE @IOF
+4 SET LRFHDR=1
+5 WRITE $$CJ^XLFSTR("PG:"_LRPAGE_" "_LRHDR(0),IOM)
+6 WRITE !,$$CJ^XLFSTR(LRHDR(0,1),IOM),!
+7 QUIT
YN(STR) ;Yes No response
+1 NEW DTOUT,DUOUT,DIRUT,X,Y,DIR
+2 SET LROK=0
SET LREND=1
+3 SET DIR(0)="Y"
SET DIR("A")=STR
SET DIR("B")="No"
+4 DO ^DIR
+5 if +$GET(Y)=1
SET LROK=1
SET LREND=0
+6 QUIT
END ;User Termination Response
+1 WRITE !,$$CJ^XLFSTR("No Surgery Data was transferred",IOM),!
+2 QUIT
FMT(VAL,IOM) ;Format line to IOM length
+1 QUIT VAL
+2 WRITE "+"
IF $LENGTH(VAL)>71
QUIT VAL
+3 IF VAL=""
SET VAL=" "
+4 SET VAL=VAL_$EXTRACT(LRLN,$LENGTH(VAL),71)
+5 QUIT VAL
+1 SET LRX=LRX+1
SET LRHDR(SEG,LRX)=LRHDR(1)
+2 SET LRX=LRX+1
SET LRHDR(SEG,LRX)=LRHDR(2)
+3 QUIT
