LRAPMRL1 ;DALOI/STAFF - AP MODIFY RELEASED REPORT CONT'D ;11/04/11 10:47
;;5.2;LAB SERVICE;**259,317,397,350**;Sep 27, 1994;Build 230
;
Q
RELCHK ; Perform series of checks
N RPCOMDT
S LRQUIT=0
I LRAU,$G(^LR(LRDFN,"AU"))="" D Q
. S LRMSG="No information found for this accession in the "
. S LRMSG=LRMSG_"LAB DATA file (#63)."
. D EN^DDIOL(LRMSG,"","!!") K LRMSG
. S LRQUIT=1
Q:LRQUIT
K LRREL
D RELEASE^LRAPUTL(.LRREL,LRDFN,LRSS,$G(LRI))
I 'LRREL(1) D
. Q:'LRAU&($G(LRREL(3)))
. ;KLL-SKIP THIS MSG IF AU RPT COMP DATE IS SET
. S RPCOMDT=$$GET1^DIQ(63,LRDFN,13,"I")
. Q:LRAU&($G(RPCOMDT))
. S LRMSG=$C(7)_"Report has not been released. Do not use this "
. S LRMSG=LRMSG_"option."
. D EN^DDIOL(LRMSG,"","!!") K LRMSG
. S LRQUIT=1
; Has a supplemental rept been entered, but not yet released? Don't allow modifications until supplemental rept. is released.
N LRSR,LRSR1,LRSR2
S LRSR=0,LRSR1=1
I LRREL(1),'LRAU D
. Q:'+$P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4)
. F S LRSR=$O(^LR(LRDFN,LRSS,LRI,1.2,LRSR)) Q:LRSR'>0!('LRSR1) D
. . S LRSR1=+$P(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U,2)
. . I 'LRSR1 D
. . . S Y=+$P(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U)
. . . D DD^%DT S LRSR2=Y
I LRREL(1),LRAU D
. S RPCOMDT=$$GET1^DIQ(63,LRDFN,13,"I")
. Q:'RPCOMDT
. Q:'+$P($G(^LR(LRDFN,84,0)),U,4)
. F S LRSR=$O(^LR(LRDFN,84,LRSR)) Q:LRSR'>0!('LRSR1) D
. . S LRSR1=+$P(^LR(LRDFN,84,LRSR,0),U,2)
. . I 'LRSR1 D
. . . S Y=+$P(^LR(LRDFN,84,LRSR,0),U)
. . . D DD^%DT S LRSR2=Y
I 'LRSR1 D
. S LRQUIT=1
. W $C(7),!,"Supplementary report "_LRSR2_" has not been released. "
. W !,"Cannot modify the report."
. S Y=0
Q
;
;
RELEASE ; Unrelease report
N LRNTIME,RPCOMDT
D NOW^%DTC S LRNTIME=%
K LRFDA
I 'LRAU D
. I '$G(LRREL(3)) S LRFDA(LRSF,LRIENS,.15)=LRREL(1)
. S LRFDA(LRSF,LRIENS,.11)="@"
. S LRFDA(LRSF,LRIENS,.13)="@"
. S LRFDA(LRSF,LRIENS,.17)=LRNTIME
. S LRFDA(LRSF,LRIENS,.171)=DUZ
I LRAU D
. S LRFDA(63,LRIENS,14.7)="@"
. S LRFDA(63,LRIENS,14.8)="@"
. ;KLL-ONLY IF REPT COMP DATE IS SET,OK TO MARK AS MODIFIED
. S RPCOMDT=$$GET1^DIQ(63,LRIENS,13,"I")
. I RPCOMDT D
. . S LRFDA(63,LRIENS,102)=LRNTIME
. . S LRFDA(63,LRIENS,102.1)=DUZ
D FILE^DIE("","LRFDA")
Q
;
;
QUEUPD ;Update the final report print queue
I '$D(^LRO(69.2,LRAA,2,LRAN,0)) D
. K LRFDA
. L +^LRO(69.2,LRAA,2):DILOCKTM I '$T D Q
. . S MSG(1)="The final reports queue is in use by another person. "
. . S MSG(1,"F")="!!"
. . S MSG(2)="You will need to add this accession to the queue later."
. . D EN^DDIOL(.MSG) K MSG
. S LRIENS="+1,"_LRAA_","
. S LRFDA(69.23,LRIENS,.01)=LRDFN
. S LRFDA(69.23,LRIENS,1)=LRI
. S LRFDA(69.23,LRIENS,2)=LRH(0)
. S LRORIEN(1)=LRAN
. D UPDATE^DIE("","LRFDA","LRORIEN") K LRORIEN
. L -^LRO(69.2,LRAA,2)
Q
;
;
EDIT ;
W !
I 'LRAU S DA=LRI,DA(1)=LRDFN,DIE="^LR("_LRDFN_","""_LRSS_""","
S:LRAU DIE="^LR(",DA=LRDFN
D ^DIE
S:$D(Y) LRQUIT=1
S:$G(DTOUT) LRQUIT=1
Q
;
;
SETDR ; Set the DR string
I LRAU D
. K DR
. S DR="13;13.01///^S X=LRWHO;32.1;99;11;14.1;14.5;14.6;12.1;"
. S DR=DR_"13.5;13.6;13.8;32;80;"
. S:LRWM DR=DR_"16:24;26:31;25;31.1;31.4;25.1;25.9"
. S DR(2,63.2)=".01;I 'LREFPD S Y=4;1;1.5;3;4;5"
. S DR(3,63.21)=".01",DR(3,63.22)=".01;I 'LREFPD S Y=0;1"
. S DR(3,63.24)=".01;S:'$P(^LAB(61.5,X,0),U,3) Y=0;.02"
. S DR(4,63.23)=".01"
I 'LRAU D
. S LRV=+$P($G(^LRO(69.2,LRAA,0)),U,10) ;Ask TC codes?
. K DR
. S DR=".08;.07;.011;.012;.013;.014;.015;.016;.1;.02;.021;.99;.97;"
. S DR=DR_"10;80;.09///^S X=LRWHO;.03"
. I LRSS="SP" D
. . S DR(2,63.12)=".01;S LR(8)=$P(^LAB(61,X,0),U,4);S:'LR(8) Y=4;2;4;"
. . S DR(2,63.12)=DR(2,63.12)_"I 'LREFPD S Y=5;1;1.5;3;5"
. .S DR(2,63.812)=".01;.06R;.07R"
. . S DR(3,63.16)=".01;I 'LREFPD S Y=0;1"
. . S DR(3,63.82)=".01;D R^LRAPD;.02"
. I LRSS="CY" D
. . S DR(2,63.902)=".01;.02;.06R;.07R"
. . S DR(2,63.912)=".01;S LR(8)=$P(^LAB(61,X,0),U,4);S:'LR(8) Y=4;2;4;"
. . S DR(2,63.912)=DR(2,63.912)_"I 'LREFPD S Y=5;1;1.5;3;5"
. . S DR(3,63.916)=".01;I 'LREFPD S Y=0;1"
. . S DR(3,63.982)=".01;D R^LRAPD;.02"
. I LRSS="EM" D
. . S DR(2,63.202)=".01;.06R;.07R"
. . S DR(2,63.212)=".01;S LR(8)=$P(^LAB(61,X,0),U,4);S:'LR(8) Y=4;2;4;"
. . S DR(2,63.212)=DR(2,63.212)_"I 'LREFPD S Y=5;1;1.5;3;5"
. . S DR(3,63.216)=".01;I 'LREFPD S Y=0;1"
. . S DR(3,63.282)=".01;S:'$P(^LAB(61.5,X,0),U,3) Y=0;.02"
Q
;
;
CPTCODE ; Enter CPT codes
K DIR
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Enter CPT CODING"
D ^DIR
I Y="^"!(Y<1) S LRQUIT=1 Q
N LRPRO
; SET PROVIDER=CURRENT USER, ALLOW UPDATES
S LRPRO=DUZ
D PROVIDR^LRAPUTL
Q:LRQUIT
D CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPMRL1 4746 printed Apr 09, 2024@21:25:51 Page 2
LRAPMRL1 ;DALOI/STAFF - AP MODIFY RELEASED REPORT CONT'D ;11/04/11 10:47
+1 ;;5.2;LAB SERVICE;**259,317,397,350**;Sep 27, 1994;Build 230
+2 ;
+3 QUIT
RELCHK ; Perform series of checks
+1 NEW RPCOMDT
+2 SET LRQUIT=0
+3 IF LRAU
IF $GET(^LR(LRDFN,"AU"))=""
Begin DoDot:1
+4 SET LRMSG="No information found for this accession in the "
+5 SET LRMSG=LRMSG_"LAB DATA file (#63)."
+6 DO EN^DDIOL(LRMSG,"","!!")
KILL LRMSG
+7 SET LRQUIT=1
End DoDot:1
QUIT
+8 if LRQUIT
QUIT
+9 KILL LRREL
+10 DO RELEASE^LRAPUTL(.LRREL,LRDFN,LRSS,$GET(LRI))
+11 IF 'LRREL(1)
Begin DoDot:1
+12 if 'LRAU&($GET(LRREL(3)))
QUIT
+13 ;KLL-SKIP THIS MSG IF AU RPT COMP DATE IS SET
+14 SET RPCOMDT=$$GET1^DIQ(63,LRDFN,13,"I")
+15 if LRAU&($GET(RPCOMDT))
QUIT
+16 SET LRMSG=$CHAR(7)_"Report has not been released. Do not use this "
+17 SET LRMSG=LRMSG_"option."
+18 DO EN^DDIOL(LRMSG,"","!!")
KILL LRMSG
+19 SET LRQUIT=1
End DoDot:1
+20 ; Has a supplemental rept been entered, but not yet released? Don't allow modifications until supplemental rept. is released.
+21 NEW LRSR,LRSR1,LRSR2
+22 SET LRSR=0
SET LRSR1=1
+23 IF LRREL(1)
IF 'LRAU
Begin DoDot:1
+24 if '+$PIECE($GET(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4)
QUIT
+25 FOR
SET LRSR=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRSR))
if LRSR'>0!('LRSR1)
QUIT
Begin DoDot:2
+26 SET LRSR1=+$PIECE(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U,2)
+27 IF 'LRSR1
Begin DoDot:3
+28 SET Y=+$PIECE(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U)
+29 DO DD^%DT
SET LRSR2=Y
End DoDot:3
End DoDot:2
End DoDot:1
+30 IF LRREL(1)
IF LRAU
Begin DoDot:1
+31 SET RPCOMDT=$$GET1^DIQ(63,LRDFN,13,"I")
+32 if 'RPCOMDT
QUIT
+33 if '+$PIECE($GET(^LR(LRDFN,84,0)),U,4)
QUIT
+34 FOR
SET LRSR=$ORDER(^LR(LRDFN,84,LRSR))
if LRSR'>0!('LRSR1)
QUIT
Begin DoDot:2
+35 SET LRSR1=+$PIECE(^LR(LRDFN,84,LRSR,0),U,2)
+36 IF 'LRSR1
Begin DoDot:3
+37 SET Y=+$PIECE(^LR(LRDFN,84,LRSR,0),U)
+38 DO DD^%DT
SET LRSR2=Y
End DoDot:3
End DoDot:2
End DoDot:1
+39 IF 'LRSR1
Begin DoDot:1
+40 SET LRQUIT=1
+41 WRITE $CHAR(7),!,"Supplementary report "_LRSR2_" has not been released. "
+42 WRITE !,"Cannot modify the report."
+43 SET Y=0
End DoDot:1
+44 QUIT
+45 ;
+46 ;
RELEASE ; Unrelease report
+1 NEW LRNTIME,RPCOMDT
+2 DO NOW^%DTC
SET LRNTIME=%
+3 KILL LRFDA
+4 IF 'LRAU
Begin DoDot:1
+5 IF '$GET(LRREL(3))
SET LRFDA(LRSF,LRIENS,.15)=LRREL(1)
+6 SET LRFDA(LRSF,LRIENS,.11)="@"
+7 SET LRFDA(LRSF,LRIENS,.13)="@"
+8 SET LRFDA(LRSF,LRIENS,.17)=LRNTIME
+9 SET LRFDA(LRSF,LRIENS,.171)=DUZ
End DoDot:1
+10 IF LRAU
Begin DoDot:1
+11 SET LRFDA(63,LRIENS,14.7)="@"
+12 SET LRFDA(63,LRIENS,14.8)="@"
+13 ;KLL-ONLY IF REPT COMP DATE IS SET,OK TO MARK AS MODIFIED
+14 SET RPCOMDT=$$GET1^DIQ(63,LRIENS,13,"I")
+15 IF RPCOMDT
Begin DoDot:2
+16 SET LRFDA(63,LRIENS,102)=LRNTIME
+17 SET LRFDA(63,LRIENS,102.1)=DUZ
End DoDot:2
End DoDot:1
+18 DO FILE^DIE("","LRFDA")
+19 QUIT
+20 ;
+21 ;
QUEUPD ;Update the final report print queue
+1 IF '$DATA(^LRO(69.2,LRAA,2,LRAN,0))
Begin DoDot:1
+2 KILL LRFDA
+3 LOCK +^LRO(69.2,LRAA,2):DILOCKTM
IF '$TEST
Begin DoDot:2
+4 SET MSG(1)="The final reports queue is in use by another person. "
+5 SET MSG(1,"F")="!!"
+6 SET MSG(2)="You will need to add this accession to the queue later."
+7 DO EN^DDIOL(.MSG)
KILL MSG
End DoDot:2
QUIT
+8 SET LRIENS="+1,"_LRAA_","
+9 SET LRFDA(69.23,LRIENS,.01)=LRDFN
+10 SET LRFDA(69.23,LRIENS,1)=LRI
+11 SET LRFDA(69.23,LRIENS,2)=LRH(0)
+12 SET LRORIEN(1)=LRAN
+13 DO UPDATE^DIE("","LRFDA","LRORIEN")
KILL LRORIEN
+14 LOCK -^LRO(69.2,LRAA,2)
End DoDot:1
+15 QUIT
+16 ;
+17 ;
EDIT ;
+1 WRITE !
+2 IF 'LRAU
SET DA=LRI
SET DA(1)=LRDFN
SET DIE="^LR("_LRDFN_","""_LRSS_""","
+3 if LRAU
SET DIE="^LR("
SET DA=LRDFN
+4 DO ^DIE
+5 if $DATA(Y)
SET LRQUIT=1
+6 if $GET(DTOUT)
SET LRQUIT=1
+7 QUIT
+8 ;
+9 ;
SETDR ; Set the DR string
+1 IF LRAU
Begin DoDot:1
+2 KILL DR
+3 SET DR="13;13.01///^S X=LRWHO;32.1;99;11;14.1;14.5;14.6;12.1;"
+4 SET DR=DR_"13.5;13.6;13.8;32;80;"
+5 if LRWM
SET DR=DR_"16:24;26:31;25;31.1;31.4;25.1;25.9"
+6 SET DR(2,63.2)=".01;I 'LREFPD S Y=4;1;1.5;3;4;5"
+7 SET DR(3,63.21)=".01"
SET DR(3,63.22)=".01;I 'LREFPD S Y=0;1"
+8 SET DR(3,63.24)=".01;S:'$P(^LAB(61.5,X,0),U,3) Y=0;.02"
+9 SET DR(4,63.23)=".01"
End DoDot:1
+10 IF 'LRAU
Begin DoDot:1
+11 ;Ask TC codes?
SET LRV=+$PIECE($GET(^LRO(69.2,LRAA,0)),U,10)
+12 KILL DR
+13 SET DR=".08;.07;.011;.012;.013;.014;.015;.016;.1;.02;.021;.99;.97;"
+14 SET DR=DR_"10;80;.09///^S X=LRWHO;.03"
+15 IF LRSS="SP"
Begin DoDot:2
+16 SET DR(2,63.12)=".01;S LR(8)=$P(^LAB(61,X,0),U,4);S:'LR(8) Y=4;2;4;"
+17 SET DR(2,63.12)=DR(2,63.12)_"I 'LREFPD S Y=5;1;1.5;3;5"
+18 SET DR(2,63.812)=".01;.06R;.07R"
+19 SET DR(3,63.16)=".01;I 'LREFPD S Y=0;1"
+20 SET DR(3,63.82)=".01;D R^LRAPD;.02"
End DoDot:2
+21 IF LRSS="CY"
Begin DoDot:2
+22 SET DR(2,63.902)=".01;.02;.06R;.07R"
+23 SET DR(2,63.912)=".01;S LR(8)=$P(^LAB(61,X,0),U,4);S:'LR(8) Y=4;2;4;"
+24 SET DR(2,63.912)=DR(2,63.912)_"I 'LREFPD S Y=5;1;1.5;3;5"
+25 SET DR(3,63.916)=".01;I 'LREFPD S Y=0;1"
+26 SET DR(3,63.982)=".01;D R^LRAPD;.02"
End DoDot:2
+27 IF LRSS="EM"
Begin DoDot:2
+28 SET DR(2,63.202)=".01;.06R;.07R"
+29 SET DR(2,63.212)=".01;S LR(8)=$P(^LAB(61,X,0),U,4);S:'LR(8) Y=4;2;4;"
+30 SET DR(2,63.212)=DR(2,63.212)_"I 'LREFPD S Y=5;1;1.5;3;5"
+31 SET DR(3,63.216)=".01;I 'LREFPD S Y=0;1"
+32 SET DR(3,63.282)=".01;S:'$P(^LAB(61.5,X,0),U,3) Y=0;.02"
End DoDot:2
End DoDot:1
+33 QUIT
+34 ;
+35 ;
CPTCODE ; Enter CPT codes
+1 KILL DIR
+2 SET DIR(0)="Y"
SET DIR("B")="NO"
+3 SET DIR("A")="Enter CPT CODING"
+4 DO ^DIR
+5 IF Y="^"!(Y<1)
SET LRQUIT=1
QUIT
+6 NEW LRPRO
+7 ; SET PROVIDER=CURRENT USER, ALLOW UPDATES
+8 SET LRPRO=DUZ
+9 DO PROVIDR^LRAPUTL
+10 if LRQUIT
QUIT
+11 DO CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO)
+12 QUIT
