BLRALFN ;DAOU/ALA-Lab ES Functions [ 11/18/2002 1:36 PM ]
;;5.2;LR;**1013,1015**;NOV 18, 2002
;
;**Program Description**
; Lab Electronic Signature functions
;
FPS ; Full Patient Summary
; Call the current Full Patient Summary code but bypass
; the selection of the patient which is already defined
;
NEW LRIDT
S LRIN=0,LRIDT=0,LREND=0,LROUT=9999999,LRDIS=0 K ZTRTN,DIC,X2
I $G(LRDFN)="" Q
;
D PT^LRX
W !,"** WARNING! This report must be queued to a printer. **"
;HANG 1
N DIR,X,Y
K DIR S DIR(0)="E",DIR("T")=10,DIR("A")="Press return to continue " D ^DIR
K DIR,X,Y
;
D QUE^LRACSUM G:POP END
I $D(ZTSK) S IOP="HOME" D ^%ZIS
I '$D(ZTSK) D LRLLOC^LRACSUM
;
S BLDATA=$G(^TMP("BLRA",$J,"ZNODE",ACN))
S LRDFN=$P(BLDATA,U,1),LRSS=$P(BLDATA,U,2),LRIDT=$P(BLDATA,U,3)
I $E(LRSS,1,2)="CH" D CH^BLRALBD
I $E(LRSS,1,2)="MI" D MI^BLRALBD
;NEW VALMCNT
S VALMCNT=+$G(BLRADSP)
S VALMBCK="R"
;
K LRDPF
I $D(ZTSK) K ZTSK Q
Q
END ;
; END^LRACM is killing too many variables, we may need to
; retain some to return back to ListMan
;D END^LRACM
;D ^%ZISC
;
S VALMBCK="R"
Q
;
FWD ; Forward a MailMan message with the Lab Results
K ^TMP($J,"BLRAMSG"),^BLRALAB(9009027.1,DUZ,100)
S DIR(0)="Y"
S DIR("A")="Do you wish to add additional comments to send with this lab result"
D ^DIR I $G(Y)=1 D WP
;
; Get the data from the word processing field
S BLRANN=0
F S BLRANN=$O(^BLRALAB(9009027.1,DUZ,100,BLRANN)) Q:'BLRANN D
. S BLRALL=$G(BLRALL)+1
. S ^TMP($J,"BLRAMSG",BLRALL,0)=$G(^BLRALAB(9009027.1,DUZ,100,BLRANN,0))
;
; Separate lab result build from additional text with a
; new line
S BLRALL=$G(BLRALL)+1,^TMP($J,"BLRAMSG",BLRALL,0)=" "
;
; If clinical chem, set the patient header first
I LRSS="CH" D
. F BLRAI=1:1:3 S BLRALL=$G(BLRALL)+1,^TMP($J,"BLRAMSG",BLRALL,0)=VALMHDR(BLRAI)
;
S BLRANN=0
F S BLRANN=$O(^TMP($J,"BLRA",BLRANN)) Q:'BLRANN D
. S BLRALL=$G(BLRALL)+1
. S ^TMP($J,"BLRAMSG",BLRALL,0)=$G(^TMP($J,"BLRA",BLRANN,0))
;
S XMSUB="LAB RESULT FOR YOUR REVIEW",XMDUZ=DUZ
S XMTEXT="^TMP($J,""BLRAMSG"","
;
; if no XMY is defined, MailMan should ask for recipients
D ^XMD
;
K XMZ,XMTEXT,XMSUB,XMDUZ,BLRALL,BLRANN,DIR,Y,^TMP($J,"BLRAMSG")
;
S VALMBCK="R"
Q
;
WP ; Using FileMan word-processing, add additional comments
S DWLW=75,DWPK=1,DIC="^BLRALAB(9009027.1,"_DUZ_",100,"
D EN^DIWE
;
Q
;
REA ; Reassign a lab result to another participating provider
;
; Parameters
; BLRAFPH = The 'From Physician'
; BLRATPH = The 'To Physician'
; TERMDT = Termination Date
; BLRADATA = Lab ES data
; BLRARPHY = Responsible Physician
; BLRARFL = Result Status Flag
;
S BLRAFPH=DUZ
;
RTO S DIC("A")="Select PARTICIPATING PHYSICIAN reassigning this lab TO: "
S DIC="^BLRALAB(9009027.1,",DIC(0)="AEMNZ" D ^DIC
Q:Y<1 S BLRATPH=+Y
S TERMDT=$$GET1^DIQ(200,BLRATPH,9.2,"I")
I TERMDT'=""&(TERMDT'>DT) D EN^DDIOL("This provider has a termination date, please select another") G RTO
;
D FILR
K BLRAFPH,BLRATPH,TERMDT,Y,BLRADATA,BLRARPHY,BLRARFL
;
Q
;
FILR ;EP
S BLRADATA=$G(^LR(LRDFN,LRSS,LRIDT,9009027))
S BLRARPHY=$P(BLRADATA,U,2),BLRARFL=$P(BLRADATA,U)
D KX^BLRALUT1
;
S $P(BLRADATA,U,2)=BLRATPH
S ^LR(LRDFN,LRSS,LRIDT,9009027)=BLRADATA
S BLRARPHY=BLRATPH
D SX^BLRALUT1
Q
BLRALFN ;DAOU/ALA-Lab ES Functions [ 11/18/2002 1:36 PM ]
+1 ;;5.2;LR;**1013,1015**;NOV 18, 2002
+2 ;
+3 ;**Program Description**
+4 ; Lab Electronic Signature functions
+5 ;
FPS ; Full Patient Summary
+1 ; Call the current Full Patient Summary code but bypass
+2 ; the selection of the patient which is already defined
+3 ;
+4 NEW LRIDT
+5 SET LRIN=0
SET LRIDT=0
SET LREND=0
SET LROUT=9999999
SET LRDIS=0
KILL ZTRTN,DIC,X2
+6 IF $GET(LRDFN)=""
QUIT
+7 ;
+8 DO PT^LRX
+9 WRITE !,"** WARNING! This report must be queued to a printer. **"
+10 ;HANG 1
+11 NEW DIR,X,Y
+12 KILL DIR
SET DIR(0)="E"
SET DIR("T")=10
SET DIR("A")="Press return to continue "
DO ^DIR
+13 KILL DIR,X,Y
+14 ;
+15 DO QUE^LRACSUM
IF POP
GOTO END
+16 IF $DATA(ZTSK)
SET IOP="HOME"
DO ^%ZIS
+17 IF '$DATA(ZTSK)
DO LRLLOC^LRACSUM
+18 ;
+19 SET BLDATA=$GET(^TMP("BLRA",$JOB,"ZNODE",ACN))
+20 SET LRDFN=$PIECE(BLDATA,U,1)
SET LRSS=$PIECE(BLDATA,U,2)
SET LRIDT=$PIECE(BLDATA,U,3)
+21 IF $EXTRACT(LRSS,1,2)="CH"
DO CH^BLRALBD
+22 IF $EXTRACT(LRSS,1,2)="MI"
DO MI^BLRALBD
+23 ;NEW VALMCNT
+24 SET VALMCNT=+$GET(BLRADSP)
+25 SET VALMBCK="R"
+26 ;
+27 KILL LRDPF
+28 IF $DATA(ZTSK)
KILL ZTSK
QUIT
+29 QUIT
END ;
+1 ; END^LRACM is killing too many variables, we may need to
+2 ; retain some to return back to ListMan
+3 ;D END^LRACM
+4 ;D ^%ZISC
+5 ;
+6 SET VALMBCK="R"
+7 QUIT
+8 ;
FWD ; Forward a MailMan message with the Lab Results
+1 KILL ^TMP($JOB,"BLRAMSG"),^BLRALAB(9009027.1,DUZ,100)
+2 SET DIR(0)="Y"
+3 SET DIR("A")="Do you wish to add additional comments to send with this lab result"
+4 DO ^DIR
IF $GET(Y)=1
DO WP
+5 ;
+6 ; Get the data from the word processing field
+7 SET BLRANN=0
+8 FOR
SET BLRANN=$ORDER(^BLRALAB(9009027.1,DUZ,100,BLRANN))
IF 'BLRANN
QUIT
Begin DoDot:1
+9 SET BLRALL=$GET(BLRALL)+1
+10 SET ^TMP($JOB,"BLRAMSG",BLRALL,0)=$GET(^BLRALAB(9009027.1,DUZ,100,BLRANN,0))
End DoDot:1
+11 ;
+12 ; Separate lab result build from additional text with a
+13 ; new line
+14 SET BLRALL=$GET(BLRALL)+1
SET ^TMP($JOB,"BLRAMSG",BLRALL,0)=" "
+15 ;
+16 ; If clinical chem, set the patient header first
+17 IF LRSS="CH"
Begin DoDot:1
+18 FOR BLRAI=1:1:3
SET BLRALL=$GET(BLRALL)+1
SET ^TMP($JOB,"BLRAMSG",BLRALL,0)=VALMHDR(BLRAI)
End DoDot:1
+19 ;
+20 SET BLRANN=0
+21 FOR
SET BLRANN=$ORDER(^TMP($JOB,"BLRA",BLRANN))
IF 'BLRANN
QUIT
Begin DoDot:1
+22 SET BLRALL=$GET(BLRALL)+1
+23 SET ^TMP($JOB,"BLRAMSG",BLRALL,0)=$GET(^TMP($JOB,"BLRA",BLRANN,0))
End DoDot:1
+24 ;
+25 SET XMSUB="LAB RESULT FOR YOUR REVIEW"
SET XMDUZ=DUZ
+26 SET XMTEXT="^TMP($J,""BLRAMSG"","
+27 ;
+28 ; if no XMY is defined, MailMan should ask for recipients
+29 DO ^XMD
+30 ;
+31 KILL XMZ,XMTEXT,XMSUB,XMDUZ,BLRALL,BLRANN,DIR,Y,^TMP($JOB,"BLRAMSG")
+32 ;
+33 SET VALMBCK="R"
+34 QUIT
+35 ;
WP ; Using FileMan word-processing, add additional comments
+1 SET DWLW=75
SET DWPK=1
SET DIC="^BLRALAB(9009027.1,"_DUZ_",100,"
+2 DO EN^DIWE
+3 ;
+4 QUIT
+5 ;
REA ; Reassign a lab result to another participating provider
+1 ;
+2 ; Parameters
+3 ; BLRAFPH = The 'From Physician'
+4 ; BLRATPH = The 'To Physician'
+5 ; TERMDT = Termination Date
+6 ; BLRADATA = Lab ES data
+7 ; BLRARPHY = Responsible Physician
+8 ; BLRARFL = Result Status Flag
+9 ;
+10 SET BLRAFPH=DUZ
+11 ;
RTO SET DIC("A")="Select PARTICIPATING PHYSICIAN reassigning this lab TO: "
+1 SET DIC="^BLRALAB(9009027.1,"
SET DIC(0)="AEMNZ"
DO ^DIC
+2 IF Y<1
QUIT
SET BLRATPH=+Y
+3 SET TERMDT=$$GET1^DIQ(200,BLRATPH,9.2,"I")
+4 IF TERMDT'=""&(TERMDT'>DT)
DO EN^DDIOL("This provider has a termination date, please select another")
GOTO RTO
+5 ;
+6 DO FILR
+7 KILL BLRAFPH,BLRATPH,TERMDT,Y,BLRADATA,BLRARPHY,BLRARFL
+8 ;
+9 QUIT
+10 ;
FILR ;EP
+1 SET BLRADATA=$GET(^LR(LRDFN,LRSS,LRIDT,9009027))
+2 SET BLRARPHY=$PIECE(BLRADATA,U,2)
SET BLRARFL=$PIECE(BLRADATA,U)
+3 DO KX^BLRALUT1
+4 ;
+5 SET $PIECE(BLRADATA,U,2)=BLRATPH
+6 SET ^LR(LRDFN,LRSS,LRIDT,9009027)=BLRADATA
+7 SET BLRARPHY=BLRATPH
+8 DO SX^BLRALUT1
+9 QUIT
