Routine: BLRALFN

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

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"

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"

WP ;  Using FileMan word-processing, add additional comments

 S DWLW=75,DWPK=1,DIC="^BLRALAB(9009027.1,"_DUZ_",100,"

 D EN^DIWE

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

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

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

BLRALFN.m