BLRESIGR ; IHS/OIT/MKK - Laboratory E-SIG Reports ; [ 04/12/06 4:00 PM ]
;;5.2;LR;**1022**;September 20, 2007
;
; NOTE: The LRIDT variable in the LR("BLRA") index is stored as a
; negative number. That is why, in several places, the code does a
; -(LRIDT).
;
; This routine also makes extensive use of the BLRGMENU (generic
; menu driver) routine. See notes there regarding its calls.
;
; The main reason to use the BLRGMENU routine instead of making the
; various calls OPTIONs in the OPTION file is to make certain all the
; variables used in this routine are NEWed. This means the variables
; will NOT interfere with other LAB routines.
;
EEP ; Ersatz EP
W $C(7),$C(7),$C(7),!
W "Use Label Only",!
W $C(7),$C(7),$C(7),!
Q
;
PEP ; "Real" EP
;
; This should never happen, BUT need to determine if IHS E-SIG
; is turned on -- if NOT, bail out
I $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2))'=1 D Q
. W !!,"IHS LR*5.2*1013 E-SIG is NOT on.",!!
. D BLRGPGR^BLRGMENU(10) ; Press RETURN prompt
;
; NEW variables so that they do not impact any other routines
NEW BLRA,ESPHY,STATUS,LRIDT,LRDFN,LRAA,LRAS,LRAD,SPHY
NEW BLRMMENU,BLRESIGR,ESIGIEN
NEW NRESP,NSIGN,RESP,SIGN,CNT,PHYCNT,TOTCNT
NEW HEADER,LINES,MAXLINES,QFLG,HLCNT
NEW PATN,ACCN
NEW BEGIDT,ENDIDT
NEW PHYSUR,PHYSURG
NEW SIGNDT,SELPHYS
;
D SETMENU
D MENUDRFM^BLRGMENU("LAB E-SIG Reports") ; Main Menu driver
;
D ^XBCLS
W !,?11,"Lab E-SIG Menu"
Q
;
K BLRMMENU
D ADDTMENU^BLRGMENU("ALLESIGS^BLRESIGR","All E-SIG Transactions")
D ADDTMENU^BLRGMENU("ALLESIGN^BLRESIGR","Signed Transactions")
D ADDTMENU^BLRGMENU("ALLNSIGN^BLRESIGR","Not Signed by Responsible Physician")
D ADDTMENU^BLRGMENU("NREVNSGN^BLRESRNS","Not Reviewed nor Signed Summary")
;
Q
;
; All E-Sig Transactions in LAB DATA file
ALLESIGS ; EP
D ^XBFMK ; Clear out ALL FileMan variables
S DIR("A")="Output ALL E-SIG transactions for ALL Providers"
S DIR(0)="Y",DIR("B")="YES"
D ^DIR
I X["^" D Q
. W !,?10,"Exit entered. No Report.",!
. D BLRGPGR^BLRGMENU(10) ; Press Return prompt
;
I Y=1 D ALLSTS
I Y'=1 D SELSTS
Q
;
; ALL E-Sig transactions in LAB DATA file by ALL Responsible Physicians
ALLSTS ; EP
D FULLCOMP
D FULLRPTH
D ESIGRPT("FULLRPTL")
Q
;
; ALL E-Sig transactions in LAB DATA file by SELECTED
; Responsible Physician(s)
SELSTS ;
I $$SELCTPHY="Q" Q
;
D ALLPCOMP
D FULLRPTH
D ESIGRPT("FULLRPTL")
Q
;
; Sort E-SIG data
FULLCOMP ;
D DATERNGE ; Get Date Range
K BLRESIGR ; Clear array
;
S ESPHY="" ; E-SIG Physician
F S ESPHY=$O(^LR("BLRA",ESPHY)) Q:ESPHY="" D
. D GETESIGD^BLRESRCD
Q
;
; Header
FULLRPTH ;
D ESIGRPTH("ALL LAB E-SIG ACCESSIONS")
S HLCNT=HLCNT+1
S HEADER(HLCNT)="RESP PHYSICIAN"
S $E(HEADER(HLCNT),17)="ACC #"
S $E(HEADER(HLCNT),37)="COLL DATE/TIME"
S $E(HEADER(HLCNT),53)="STATUS"
S $E(HEADER(HLCNT),66)="SIGN PHYSICIAN"
;
Q
;
; Output line of data
FULLRPTL ;
D ESIGBRKO
;
I LINES>MAXLINES D BLRGHWPN^BLRGMENU(.PG,.QFLG) I QFLG="Q" Q
;
W $E(NRESP,1,15)
W ?16,ACCN
W ?36,$$FMTE^XLFDT(COLLDTT,"2MZ")
W ?52,$E(STATUS,1,12)
W ?65,$E(NSIGN,1,15)
W !
S LINES=LINES+1
S CNT=CNT+1
Q
;
; Initialize HEADER array
ESIGRPTH(HEAD1) ;
NEW RANGESTR
;
S RANGESTR="DATE RANGE: "
S RANGESTR=RANGESTR_$$FMTE^XLFDT(LRSDT,"2DZ")
S RANGESTR=RANGESTR_" THRU "_$$FMTE^XLFDT(LRLDT,"2DZ")
S RANGESTR=$$CJ^XLFSTR(RANGESTR,IOM)
;
K HEADER
S HEADER(1)=HEAD1
S HEADER(2)="SORTED BY RESPONSIBLE PHYSICIAN"
S HEADER(3)=RANGESTR
S HEADER(4)=" "
S HLCNT=4 ; HEADER LINE COUNT
;
Q
;
ESIGRPT(WOTDLINE) ;
I $$GETDEV="Q" D Q
. W !,"Output Device Error",!!
. D BLRGPGR^BLRGMENU()
;
U IO
S (NRESP,PATN,LRAA,LRDFN,LRIDT)=""
S CNT=0
F S NRESP=$O(BLRESIGR(NRESP)) Q:NRESP=""!(QFLG="Q") D
. S PHYCNT=0
. F S PATN=$O(BLRESIGR(NRESP,PATN)) Q:PATN=""!(QFLG="Q") D
.. F S LRAA=$O(BLRESIGR(NRESP,PATN,LRAA)) Q:LRAA=""!(QFLG="Q") D
... F S LRDFN=$O(BLRESIGR(NRESP,PATN,LRAA,LRDFN)) Q:LRDFN=""!(QFLG="Q") D
.... F S LRIDT=$O(BLRESIGR(NRESP,PATN,LRAA,LRDFN,LRIDT)) Q:LRIDT=""!(QFLG="Q") D
..... D @WOTDLINE
..... S PHYCNT=PHYCNT+1
. I PHYCNT>0 D
.. W !
.. S LINES=LINES+1
;
D ^%ZISC ; Close IO port
;
W !!,"Number of records = ",CNT,!!
;
D BLRGPGR^BLRGMENU()
Q
;
GETDEV() ; EP
D ^%ZIS
I POP>0 Q "Q"
;
S PG=0
S MAXLINES=IOSL-4
S LINES=MAXLINES+10
S QFLG="NO"
;
Q "OK"
;
; "Break out" BLRESIGR array variables
ESIGBRKO ;
S ACCN=$P($G(^LR(LRDFN,LRAA,LRIDT,0)),"^",6) ; Accession Number
S COLLDTT=$P($G(^LR(LRDFN,LRAA,LRIDT,0)),"^",1) ; Collection Date/Time
S STATUS=$P($G(^LR(LRDFN,LRAA,LRIDT,9009027)),"^",1) ; E-SIG Transaction Status
S STATUS=$S(STATUS=0:"NOT REVIEWED",STATUS=1:"REVIEWED",STATUS=2:"REV & SIGNED",1:"<UNK>")
;
S SIGN=$P($G(^LR(LRDFN,LRAA,LRIDT,9009027)),"^",3) ; Signing Physician's IEN
I SIGN="" S NSIGN="" Q
S NSIGN=$P($G(^VA(200,SIGN,0)),"^",1) ; Signing Physician's Name
S SIGNDT=$P($G(^LR(LRDFN,LRAA,LRIDT,9009027)),"^",5)
Q
;
; Select E-SIG participating Physician(s)
SELCTPHY() ;
NEW FLG,PHYCNT
K SELPHYS
;
S FLG="OK",PHYCNT=0
F D Q:FLG'="OK"
. S FLG=$$GETPHYIN
. I FLG="Q" Q
. ;
. S SELPHYS(ESIGIEN)=""
. S PHYCNT=PHYCNT+1
. W !
;
I PHYCNT<1 D Q "Q"
. W !,"No Providers selected",!
. D BLRGPGR^BLRGMENU()
;
Q "OK"
;
; Get E-SIG Physician's Internal Entry Number (IEN)
GETPHYIN() ;
D ^XBFMK
S DIC=9009027.1
S DIC(0)="QEAZ"
D ^DIC
I Y<1 Q "Q"
I X["^"!($G(X)="") Q "Q"
;
S ESIGIEN=+Y
Q "OK"
;
; Sort E-SIG data using Selected Physicians
ALLPCOMP ;
D DATERNGE ; Get Date Range
K BLRESIGR ; Clear array
;
S ESPHY=""
F S ESPHY=$O(SELPHYS(ESPHY)) Q:ESPHY="" D
. D GETESIGD^BLRESRCD
;
Q
;
ALLESIGN ; EP
D ^XBFMK ; Clear out ALL FileMan variables
S DIR("A")="Output ALL E-SIG SIGNED transactions for ALL Providers"
S DIR(0)="Y",DIR("B")="YES"
D ^DIR
I X["^" D Q
. W !,?10,"Exit entered. No Report.",!
. D BLRGPGR^BLRGMENU(10) ; Press Return prompt
;
I Y=1 D ASIGNSTS
I Y'=1 D SSIGNSTS
Q
;
; ALL E-Sig Transactions with Status = 2 ==> Reviewed & Signed
ASIGNSTS ; EP
D SIGNCOMP
D SIGNRPT
Q
;
; Sort Status = 2 E-SIG data
SIGNCOMP ;
D DATERNGE
K BLRESIGR ; Clear array
;
S STATUS=2 ; Initialize variable
;
S ESPHY="" ; E-SIG Physician
F S ESPHY=$O(^LR("BLRA",ESPHY)) Q:ESPHY="" D
. S NRESP=$P($G(^VA(200,ESPHY,0)),"^",1)
. S BLRESIGR(NRESP)=ESPHY
. D GETESIG2^BLRESRCD
Q
;
SIGNRPT ;
I $$GETDEV="Q" D Q
. W !,"Output Device Error",!!
. D BLRGPGR^BLRGMENU()
;
D ESIGRPTH("SIGNED LAB E-SIG ACCESSIONS")
;
U IO
S (NRESP,PATN,LRAA,LRDFN,LRIDT)=""
S CNT=0
F S NRESP=$O(BLRESIGR(NRESP)) Q:NRESP=""!(QFLG="Q") D
. S PHYCNT=0
. F S PATN=$O(BLRESIGR(NRESP,PATN)) Q:PATN=""!(QFLG="Q") D
.. F S LRAA=$O(BLRESIGR(NRESP,PATN,LRAA)) Q:LRAA=""!(QFLG="Q") D
... F S LRDFN=$O(BLRESIGR(NRESP,PATN,LRAA,LRDFN)) Q:LRDFN=""!(QFLG="Q") D
.... F S LRIDT=$O(BLRESIGR(NRESP,PATN,LRAA,LRDFN,LRIDT)) Q:LRIDT=""!(QFLG="Q") D
..... D SIGNRPTL
. I PHYCNT>0 D
.. W !!,?10,"Number of Signed E-SIG transactions for ",NRESP," = ",PHYCNT,!
. S LINES=MAXLINES+10
;
D ^%ZISC ; Close IO port
;
D BLRGPGR^BLRGMENU()
Q
;
; Output line of data
SIGNRPTL ;
D ESIGBRKO
;
I LINES>MAXLINES D I QFLG="Q" Q
. D SURINHDR(HLCNT)
. D BLRGHWPN^BLRGMENU(.PG,.QFLG)
;
W ACCN
W ?19,$$FMTE^XLFDT(COLLDTT,"2MZ")
W ?35,$$FMTE^XLFDT(SIGNDT,"2MZ")
W ?51,$E(NSIGN,1,25)
W !
S LINES=LINES+1
S CNT=CNT+1
S PHYCNT=1+$G(PHYCNT)
Q
;
; Selected Physicians and their signed E-SIG transactions
SSIGNSTS ;
I $$SELCTPHY="Q" Q
;
D SGNPCOMP
D SIGNRPT
Q
;
SGNPCOMP ;
D DATERNGE
K BLRESIGR ; Clear array
;
S STATUS=2 ; Initialize variable
;
S ESPHY="" ; E-SIG Physician
F S ESPHY=$O(SELPHYS(ESPHY)) Q:ESPHY="" D
. S NRESP=$P($G(^VA(200,ESPHY,0)),"^",1)
. S BLRESIGR(NRESP)=ESPHY
. D GETESIG2^BLRESRCD
Q
;
ALLNSIGN ; EP
D ^XBFMK ; Clear out ALL FileMan variables
S DIR("A")="Output E-SIG transactions Not Signed by Resp Phy - ALL"
S DIR(0)="Y",DIR("B")="YES"
D ^DIR
I X["^" D Q
. W !,?10,"Exit entered. No Report.",!
. D BLRGPGR^BLRGMENU(10) ; Press Return prompt
;
I Y=1 D ANOSIGNR
I Y'=1 D SNOSIGNR
;
Q
;
; Report of NOT SIGNED by Responsible Physician for ALL Physicians
ANOSIGNR ; EP
D NSIGNCOM
D NSIGNRPT
Q
;
NSIGNCOM ;
D DATERNGE
K BLRESIGR ; Clear array
;
S STATUS=2 ; Initialize variable
;
S CNT=0
S ESPHY="" ; E-SIG Physician
F S ESPHY=$O(^LR("BLRA",ESPHY)) Q:ESPHY="" D
. S NRESP=$P($G(^VA(200,ESPHY,0)),"^",1)
. S BLRESIGR(NRESP)=ESPHY
. D NSIGNTXN^BLRESRCD
. I CNT<1 K BLRESIGR(NRESP)
Q
;
; Report of E-SIG Not Signed transaction by Responsible Physician
NSIGNRPT ;
I $$NSGNRPTH="Q" D Q
. W !,"Output Device Error",!!
. D BLRGPGR^BLRGMENU()
;
U IO
S (NRESP,PATN,LRAA,LRDFN,LRIDT)=""
F S NRESP=$O(BLRESIGR(NRESP)) Q:NRESP=""!(QFLG="Q") D
. D SURROGAT($G(BLRESIGR(NRESP)))
. ;
. S CNT=0
. F S PATN=$O(BLRESIGR(NRESP,PATN)) Q:PATN=""!(QFLG="Q") D
.. F S LRAA=$O(BLRESIGR(NRESP,PATN,LRAA)) Q:LRAA=""!(QFLG="Q") D
... F S LRDFN=$O(BLRESIGR(NRESP,PATN,LRAA,LRDFN)) Q:LRDFN=""!(QFLG="Q") D
.... F S LRIDT=$O(BLRESIGR(NRESP,PATN,LRAA,LRDFN,LRIDT)) Q:LRIDT=""!(QFLG="Q") D
..... D NSGNRPTL
. I CNT>0 W !,?10,"Number of records = ",CNT,!
. S LINES=MAXLINES+10
;
D ^%ZISC ; Close IO port
;
D BLRGPGR^BLRGMENU()
;
Q
;
; Get Surrogate(s) Information and store in PHYSURG array
SURROGAT(RESP) ;
K PHYSURG
S PHYSUR=0
F S PHYSUR=$O(^BLRALAB(9009027.1,RESP,1,PHYSUR)) Q:PHYSUR=""!(PHYSUR'?.N) D
. S SURDATES=$P(^BLRALAB(9009027.1,RESP,1,PHYSUR,0),"^",2,3)
. S SURBDT=$$FMTE^XLFDT($P(SURDATES,"^",1),"2DZ")
. S SUREDT=$$FMTE^XLFDT($P(SURDATES,"^",2),"2DZ")
. S PHYSURG(RESP,PHYSUR)=$P($G(^VA(200,PHYSUR,0)),"^",1)_"^"_SURBDT_"^"_SUREDT
Q
;
; Initialize HEADER array and IO
NSGNRPTH() ;
D ESIGRPTH("REVIEWED & NOT SIGNED BY RESP PHYSICIAN")
;
Q $$GETDEV
;
; Output line of data
NSGNRPTL ;
D ESIGBRKO
;
I LINES>MAXLINES D I QFLG="Q" Q
. D SURINHDR(HLCNT)
. D BLRGHWPN^BLRGMENU(.PG,.QFLG)
;
W ACCN
W ?19,$$FMTE^XLFDT(COLLDTT,"2MZ")
W ?35,$$FMTE^XLFDT(SIGNDT,"2MZ")
W ?51,$E(NSIGN,1,25)
W !
S LINES=LINES+1
S CNT=CNT+1
;
Q
;
; Put Surrogate(s) information in HEADER array
SURINHDR(HDCNT) ;
S HDCNT=HDCNT+1
F J=HDCNT:1:12 K HEADER(J) ; Clear out array
;
S HEADER(HDCNT)=$$CJ^XLFSTR("RESPONSIBLE PHYSICIAN:"_NRESP,IOM)
S HDCNT=HDCNT+1
;
NEW RESP
S RESP=$G(BLRESIGR(NRESP))
;
; SURROGATE Information
NEW SURDATES,SURSTR,SURBDT,SUREDT
S PHYSUR=""
F S PHYSUR=$O(PHYSURG(RESP,PHYSUR)) Q:PHYSUR=""!(QFLG="Q") D
. S SURSTR="SURROGATE:"_$P($G(PHYSURG(RESP,PHYSUR)),"^",1)
. S SURSTR=SURSTR_" BEG DATE:"_$P($G(PHYSURG(RESP,PHYSUR)),"^",2)
. S SURSTR=SURSTR_" END DATE:"_$P($G(PHYSURG(RESP,PHYSUR)),"^",3)
. S HEADER(HDCNT)=$$CJ^XLFSTR(SURSTR,IOM)
. S HDCNT=HDCNT+1
;
S HEADER(HDCNT)=" "
S HDCNT=HDCNT+1
;
S HEADER(HDCNT)="ACC #"
S $E(HEADER(HDCNT),20)="COLL DATE/TIME"
S $E(HEADER(HDCNT),36)="SIGN DATE/TIME"
S $E(HEADER(HDCNT),52)="SIGNING PHY"
;
Q
;
SNOSIGNR ;
I $$SELCTPHY="Q" Q
;
D SNSGNCOM
D NSIGNRPT
Q
;
SNSGNCOM ;
D DATERNGE
K BLRESIGR ; Clear array
;
S STATUS=2 ; Initialize variable
;
S CNT=0
S ESPHY="" ; E-SIG Physician
F S ESPHY=$O(SELPHYS(ESPHY)) Q:ESPHY="" D
. S NRESP=$P($G(^VA(200,ESPHY,0)),"^",1)
. S BLRESIGR(NRESP)=ESPHY
. D NSIGNTXN^BLRESRCD
. I CNT<1 K BLRESIGR(NRESP)
Q
;
DATERNGE ;
W !
D B^LRU
S BEGIDT=-(9999999-LRSDT)
S ENDIDT=-(9999999-(LRLDT+1))
Q
BLRESIGR ; IHS/OIT/MKK - Laboratory E-SIG Reports ; [ 04/12/06 4:00 PM ]
+1 ;;5.2;LR;**1022**;September 20, 2007
+2 ;
+3 ; NOTE: The LRIDT variable in the LR("BLRA") index is stored as a
+4 ; negative number. That is why, in several places, the code does a
+5 ; -(LRIDT).
+6 ;
+7 ; This routine also makes extensive use of the BLRGMENU (generic
+8 ; menu driver) routine. See notes there regarding its calls.
+9 ;
+10 ; The main reason to use the BLRGMENU routine instead of making the
+11 ; various calls OPTIONs in the OPTION file is to make certain all the
+12 ; variables used in this routine are NEWed. This means the variables
+13 ; will NOT interfere with other LAB routines.
+14 ;
EEP ; Ersatz EP
+1 WRITE $CHAR(7),$CHAR(7),$CHAR(7),!
+2 WRITE "Use Label Only",!
+3 WRITE $CHAR(7),$CHAR(7),$CHAR(7),!
+4 QUIT
+5 ;
PEP ; "Real" EP
+1 ;
+2 ; This should never happen, BUT need to determine if IHS E-SIG
+3 ; is turned on -- if NOT, bail out
+4 IF $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2))'=1
Begin DoDot:1
+5 WRITE !!,"IHS LR*5.2*1013 E-SIG is NOT on.",!!
+6 ; Press RETURN prompt
DO BLRGPGR^BLRGMENU(10)
End DoDot:1
QUIT
+7 ;
+8 ; NEW variables so that they do not impact any other routines
+9 NEW BLRA,ESPHY,STATUS,LRIDT,LRDFN,LRAA,LRAS,LRAD,SPHY
+10 NEW BLRMMENU,BLRESIGR,ESIGIEN
+11 NEW NRESP,NSIGN,RESP,SIGN,CNT,PHYCNT,TOTCNT
+12 NEW HEADER,LINES,MAXLINES,QFLG,HLCNT
+13 NEW PATN,ACCN
+14 NEW BEGIDT,ENDIDT
+15 NEW PHYSUR,PHYSURG
+16 NEW SIGNDT,SELPHYS
+17 ;
+18 DO SETMENU
+19 ; Main Menu driver
DO MENUDRFM^BLRGMENU("LAB E-SIG Reports")
+20 ;
+21 DO ^XBCLS
+22 WRITE !,?11,"Lab E-SIG Menu"
+23 QUIT
+24 ;
+1 KILL BLRMMENU
+2 DO ADDTMENU^BLRGMENU("ALLESIGS^BLRESIGR","All E-SIG Transactions")
+3 DO ADDTMENU^BLRGMENU("ALLESIGN^BLRESIGR","Signed Transactions")
+4 DO ADDTMENU^BLRGMENU("ALLNSIGN^BLRESIGR","Not Signed by Responsible Physician")
+5 DO ADDTMENU^BLRGMENU("NREVNSGN^BLRESRNS","Not Reviewed nor Signed Summary")
+6 ;
+7 QUIT
+8 ;
+9 ; All E-Sig Transactions in LAB DATA file
ALLESIGS ; EP
+1 ; Clear out ALL FileMan variables
DO ^XBFMK
+2 SET DIR("A")="Output ALL E-SIG transactions for ALL Providers"
+3 SET DIR(0)="Y"
SET DIR("B")="YES"
+4 DO ^DIR
+5 IF X["^"
Begin DoDot:1
+6 WRITE !,?10,"Exit entered. No Report.",!
+7 ; Press Return prompt
DO BLRGPGR^BLRGMENU(10)
End DoDot:1
QUIT
+8 ;
+9 IF Y=1
DO ALLSTS
+10 IF Y'=1
DO SELSTS
+11 QUIT
+12 ;
+13 ; ALL E-Sig transactions in LAB DATA file by ALL Responsible Physicians
ALLSTS ; EP
+1 DO FULLCOMP
+2 DO FULLRPTH
+3 DO ESIGRPT("FULLRPTL")
+4 QUIT
+5 ;
+6 ; ALL E-Sig transactions in LAB DATA file by SELECTED
+7 ; Responsible Physician(s)
SELSTS ;
+1 IF $$SELCTPHY="Q"
QUIT
+2 ;
+3 DO ALLPCOMP
+4 DO FULLRPTH
+5 DO ESIGRPT("FULLRPTL")
+6 QUIT
+7 ;
+8 ; Sort E-SIG data
FULLCOMP ;
+1 ; Get Date Range
DO DATERNGE
+2 ; Clear array
KILL BLRESIGR
+3 ;
+4 ; E-SIG Physician
SET ESPHY=""
+5 FOR
SET ESPHY=$ORDER(^LR("BLRA",ESPHY))
IF ESPHY=""
QUIT
Begin DoDot:1
+6 DO GETESIGD^BLRESRCD
End DoDot:1
+7 QUIT
+8 ;
+9 ; Header
FULLRPTH ;
+1 DO ESIGRPTH("ALL LAB E-SIG ACCESSIONS")
+2 SET HLCNT=HLCNT+1
+3 SET HEADER(HLCNT)="RESP PHYSICIAN"
+4 SET $EXTRACT(HEADER(HLCNT),17)="ACC #"
+5 SET $EXTRACT(HEADER(HLCNT),37)="COLL DATE/TIME"
+6 SET $EXTRACT(HEADER(HLCNT),53)="STATUS"
+7 SET $EXTRACT(HEADER(HLCNT),66)="SIGN PHYSICIAN"
+8 ;
+9 QUIT
+10 ;
+11 ; Output line of data
FULLRPTL ;
+1 DO ESIGBRKO
+2 ;
+3 IF LINES>MAXLINES
DO BLRGHWPN^BLRGMENU(.PG,.QFLG)
IF QFLG="Q"
QUIT
+4 ;
+5 WRITE $EXTRACT(NRESP,1,15)
+6 WRITE ?16,ACCN
+7 WRITE ?36,$$FMTE^XLFDT(COLLDTT,"2MZ")
+8 WRITE ?52,$EXTRACT(STATUS,1,12)
+9 WRITE ?65,$EXTRACT(NSIGN,1,15)
+10 WRITE !
+11 SET LINES=LINES+1
+12 SET CNT=CNT+1
+13 QUIT
+14 ;
+15 ; Initialize HEADER array
ESIGRPTH(HEAD1) ;
+1 NEW RANGESTR
+2 ;
+3 SET RANGESTR="DATE RANGE: "
+4 SET RANGESTR=RANGESTR_$$FMTE^XLFDT(LRSDT,"2DZ")
+5 SET RANGESTR=RANGESTR_" THRU "_$$FMTE^XLFDT(LRLDT,"2DZ")
+6 SET RANGESTR=$$CJ^XLFSTR(RANGESTR,IOM)
+7 ;
+8 KILL HEADER
+9 SET HEADER(1)=HEAD1
+10 SET HEADER(2)="SORTED BY RESPONSIBLE PHYSICIAN"
+11 SET HEADER(3)=RANGESTR
+12 SET HEADER(4)=" "
+13 ; HEADER LINE COUNT
SET HLCNT=4
+14 ;
+15 QUIT
+16 ;
ESIGRPT(WOTDLINE) ;
+1 IF $$GETDEV="Q"
Begin DoDot:1
+2 WRITE !,"Output Device Error",!!
+3 DO BLRGPGR^BLRGMENU()
End DoDot:1
QUIT
+4 ;
+5 USE IO
+6 SET (NRESP,PATN,LRAA,LRDFN,LRIDT)=""
+7 SET CNT=0
+8 FOR
SET NRESP=$ORDER(BLRESIGR(NRESP))
IF NRESP=""!(QFLG="Q")
QUIT
Begin DoDot:1
+9 SET PHYCNT=0
+10 FOR
SET PATN=$ORDER(BLRESIGR(NRESP,PATN))
IF PATN=""!(QFLG="Q")
QUIT
Begin DoDot:2
+11 FOR
SET LRAA=$ORDER(BLRESIGR(NRESP,PATN,LRAA))
IF LRAA=""!(QFLG="Q")
QUIT
Begin DoDot:3
+12 FOR
SET LRDFN=$ORDER(BLRESIGR(NRESP,PATN,LRAA,LRDFN))
IF LRDFN=""!(QFLG="Q")
QUIT
Begin DoDot:4
+13 FOR
SET LRIDT=$ORDER(BLRESIGR(NRESP,PATN,LRAA,LRDFN,LRIDT))
IF LRIDT=""!(QFLG="Q")
QUIT
Begin DoDot:5
+14 DO @WOTDLINE
+15 SET PHYCNT=PHYCNT+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+16 IF PHYCNT>0
Begin DoDot:2
+17 WRITE !
+18 SET LINES=LINES+1
End DoDot:2
End DoDot:1
+19 ;
+20 ; Close IO port
DO ^%ZISC
+21 ;
+22 WRITE !!,"Number of records = ",CNT,!!
+23 ;
+24 DO BLRGPGR^BLRGMENU()
+25 QUIT
+26 ;
GETDEV() ; EP
+1 DO ^%ZIS
+2 IF POP>0
QUIT "Q"
+3 ;
+4 SET PG=0
+5 SET MAXLINES=IOSL-4
+6 SET LINES=MAXLINES+10
+7 SET QFLG="NO"
+8 ;
+9 QUIT "OK"
+10 ;
+11 ; "Break out" BLRESIGR array variables
ESIGBRKO ;
+1 ; Accession Number
SET ACCN=$PIECE($GET(^LR(LRDFN,LRAA,LRIDT,0)),"^",6)
+2 ; Collection Date/Time
SET COLLDTT=$PIECE($GET(^LR(LRDFN,LRAA,LRIDT,0)),"^",1)
+3 ; E-SIG Transaction Status
SET STATUS=$PIECE($GET(^LR(LRDFN,LRAA,LRIDT,9009027)),"^",1)
+4 SET STATUS=$SELECT(STATUS=0:"NOT REVIEWED",STATUS=1:"REVIEWED",STATUS=2:"REV & SIGNED",1:"<UNK>")
+5 ;
+6 ; Signing Physician's IEN
SET SIGN=$PIECE($GET(^LR(LRDFN,LRAA,LRIDT,9009027)),"^",3)
+7 IF SIGN=""
SET NSIGN=""
QUIT
+8 ; Signing Physician's Name
SET NSIGN=$PIECE($GET(^VA(200,SIGN,0)),"^",1)
+9 SET SIGNDT=$PIECE($GET(^LR(LRDFN,LRAA,LRIDT,9009027)),"^",5)
+10 QUIT
+11 ;
+12 ; Select E-SIG participating Physician(s)
SELCTPHY() ;
+1 NEW FLG,PHYCNT
+2 KILL SELPHYS
+3 ;
+4 SET FLG="OK"
SET PHYCNT=0
+5 FOR
Begin DoDot:1
+6 SET FLG=$$GETPHYIN
+7 IF FLG="Q"
QUIT
+8 ;
+9 SET SELPHYS(ESIGIEN)=""
+10 SET PHYCNT=PHYCNT+1
+11 WRITE !
End DoDot:1
IF FLG'="OK"
QUIT
+12 ;
+13 IF PHYCNT<1
Begin DoDot:1
+14 WRITE !,"No Providers selected",!
+15 DO BLRGPGR^BLRGMENU()
End DoDot:1
QUIT "Q"
+16 ;
+17 QUIT "OK"
+18 ;
+19 ; Get E-SIG Physician's Internal Entry Number (IEN)
GETPHYIN() ;
+1 DO ^XBFMK
+2 SET DIC=9009027.1
+3 SET DIC(0)="QEAZ"
+4 DO ^DIC
+5 IF Y<1
QUIT "Q"
+6 IF X["^"!($GET(X)="")
QUIT "Q"
+7 ;
+8 SET ESIGIEN=+Y
+9 QUIT "OK"
+10 ;
+11 ; Sort E-SIG data using Selected Physicians
ALLPCOMP ;
+1 ; Get Date Range
DO DATERNGE
+2 ; Clear array
KILL BLRESIGR
+3 ;
+4 SET ESPHY=""
+5 FOR
SET ESPHY=$ORDER(SELPHYS(ESPHY))
IF ESPHY=""
QUIT
Begin DoDot:1
+6 DO GETESIGD^BLRESRCD
End DoDot:1
+7 ;
+8 QUIT
+9 ;
ALLESIGN ; EP
+1 ; Clear out ALL FileMan variables
DO ^XBFMK
+2 SET DIR("A")="Output ALL E-SIG SIGNED transactions for ALL Providers"
+3 SET DIR(0)="Y"
SET DIR("B")="YES"
+4 DO ^DIR
+5 IF X["^"
Begin DoDot:1
+6 WRITE !,?10,"Exit entered. No Report.",!
+7 ; Press Return prompt
DO BLRGPGR^BLRGMENU(10)
End DoDot:1
QUIT
+8 ;
+9 IF Y=1
DO ASIGNSTS
+10 IF Y'=1
DO SSIGNSTS
+11 QUIT
+12 ;
+13 ; ALL E-Sig Transactions with Status = 2 ==> Reviewed & Signed
ASIGNSTS ; EP
+1 DO SIGNCOMP
+2 DO SIGNRPT
+3 QUIT
+4 ;
+5 ; Sort Status = 2 E-SIG data
SIGNCOMP ;
+1 DO DATERNGE
+2 ; Clear array
KILL BLRESIGR
+3 ;
+4 ; Initialize variable
SET STATUS=2
+5 ;
+6 ; E-SIG Physician
SET ESPHY=""
+7 FOR
SET ESPHY=$ORDER(^LR("BLRA",ESPHY))
IF ESPHY=""
QUIT
Begin DoDot:1
+8 SET NRESP=$PIECE($GET(^VA(200,ESPHY,0)),"^",1)
+9 SET BLRESIGR(NRESP)=ESPHY
+10 DO GETESIG2^BLRESRCD
End DoDot:1
+11 QUIT
+12 ;
SIGNRPT ;
+1 IF $$GETDEV="Q"
Begin DoDot:1
+2 WRITE !,"Output Device Error",!!
+3 DO BLRGPGR^BLRGMENU()
End DoDot:1
QUIT
+4 ;
+5 DO ESIGRPTH("SIGNED LAB E-SIG ACCESSIONS")
+6 ;
+7 USE IO
+8 SET (NRESP,PATN,LRAA,LRDFN,LRIDT)=""
+9 SET CNT=0
+10 FOR
SET NRESP=$ORDER(BLRESIGR(NRESP))
IF NRESP=""!(QFLG="Q")
QUIT
Begin DoDot:1
+11 SET PHYCNT=0
+12 FOR
SET PATN=$ORDER(BLRESIGR(NRESP,PATN))
IF PATN=""!(QFLG="Q")
QUIT
Begin DoDot:2
+13 FOR
SET LRAA=$ORDER(BLRESIGR(NRESP,PATN,LRAA))
IF LRAA=""!(QFLG="Q")
QUIT
Begin DoDot:3
+14 FOR
SET LRDFN=$ORDER(BLRESIGR(NRESP,PATN,LRAA,LRDFN))
IF LRDFN=""!(QFLG="Q")
QUIT
Begin DoDot:4
+15 FOR
SET LRIDT=$ORDER(BLRESIGR(NRESP,PATN,LRAA,LRDFN,LRIDT))
IF LRIDT=""!(QFLG="Q")
QUIT
Begin DoDot:5
+16 DO SIGNRPTL
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+17 IF PHYCNT>0
Begin DoDot:2
+18 WRITE !!,?10,"Number of Signed E-SIG transactions for ",NRESP," = ",PHYCNT,!
End DoDot:2
+19 SET LINES=MAXLINES+10
End DoDot:1
+20 ;
+21 ; Close IO port
DO ^%ZISC
+22 ;
+23 DO BLRGPGR^BLRGMENU()
+24 QUIT
+25 ;
+26 ; Output line of data
SIGNRPTL ;
+1 DO ESIGBRKO
+2 ;
+3 IF LINES>MAXLINES
Begin DoDot:1
+4 DO SURINHDR(HLCNT)
+5 DO BLRGHWPN^BLRGMENU(.PG,.QFLG)
End DoDot:1
IF QFLG="Q"
QUIT
+6 ;
+7 WRITE ACCN
+8 WRITE ?19,$$FMTE^XLFDT(COLLDTT,"2MZ")
+9 WRITE ?35,$$FMTE^XLFDT(SIGNDT,"2MZ")
+10 WRITE ?51,$EXTRACT(NSIGN,1,25)
+11 WRITE !
+12 SET LINES=LINES+1
+13 SET CNT=CNT+1
+14 SET PHYCNT=1+$GET(PHYCNT)
+15 QUIT
+16 ;
+17 ; Selected Physicians and their signed E-SIG transactions
SSIGNSTS ;
+1 IF $$SELCTPHY="Q"
QUIT
+2 ;
+3 DO SGNPCOMP
+4 DO SIGNRPT
+5 QUIT
+6 ;
SGNPCOMP ;
+1 DO DATERNGE
+2 ; Clear array
KILL BLRESIGR
+3 ;
+4 ; Initialize variable
SET STATUS=2
+5 ;
+6 ; E-SIG Physician
SET ESPHY=""
+7 FOR
SET ESPHY=$ORDER(SELPHYS(ESPHY))
IF ESPHY=""
QUIT
Begin DoDot:1
+8 SET NRESP=$PIECE($GET(^VA(200,ESPHY,0)),"^",1)
+9 SET BLRESIGR(NRESP)=ESPHY
+10 DO GETESIG2^BLRESRCD
End DoDot:1
+11 QUIT
+12 ;
ALLNSIGN ; EP
+1 ; Clear out ALL FileMan variables
DO ^XBFMK
+2 SET DIR("A")="Output E-SIG transactions Not Signed by Resp Phy - ALL"
+3 SET DIR(0)="Y"
SET DIR("B")="YES"
+4 DO ^DIR
+5 IF X["^"
Begin DoDot:1
+6 WRITE !,?10,"Exit entered. No Report.",!
+7 ; Press Return prompt
DO BLRGPGR^BLRGMENU(10)
End DoDot:1
QUIT
+8 ;
+9 IF Y=1
DO ANOSIGNR
+10 IF Y'=1
DO SNOSIGNR
+11 ;
+12 QUIT
+13 ;
+14 ; Report of NOT SIGNED by Responsible Physician for ALL Physicians
ANOSIGNR ; EP
+1 DO NSIGNCOM
+2 DO NSIGNRPT
+3 QUIT
+4 ;
NSIGNCOM ;
+1 DO DATERNGE
+2 ; Clear array
KILL BLRESIGR
+3 ;
+4 ; Initialize variable
SET STATUS=2
+5 ;
+6 SET CNT=0
+7 ; E-SIG Physician
SET ESPHY=""
+8 FOR
SET ESPHY=$ORDER(^LR("BLRA",ESPHY))
IF ESPHY=""
QUIT
Begin DoDot:1
+9 SET NRESP=$PIECE($GET(^VA(200,ESPHY,0)),"^",1)
+10 SET BLRESIGR(NRESP)=ESPHY
+11 DO NSIGNTXN^BLRESRCD
+12 IF CNT<1
KILL BLRESIGR(NRESP)
End DoDot:1
+13 QUIT
+14 ;
+15 ; Report of E-SIG Not Signed transaction by Responsible Physician
NSIGNRPT ;
+1 IF $$NSGNRPTH="Q"
Begin DoDot:1
+2 WRITE !,"Output Device Error",!!
+3 DO BLRGPGR^BLRGMENU()
End DoDot:1
QUIT
+4 ;
+5 USE IO
+6 SET (NRESP,PATN,LRAA,LRDFN,LRIDT)=""
+7 FOR
SET NRESP=$ORDER(BLRESIGR(NRESP))
IF NRESP=""!(QFLG="Q")
QUIT
Begin DoDot:1
+8 DO SURROGAT($GET(BLRESIGR(NRESP)))
+9 ;
+10 SET CNT=0
+11 FOR
SET PATN=$ORDER(BLRESIGR(NRESP,PATN))
IF PATN=""!(QFLG="Q")
QUIT
Begin DoDot:2
+12 FOR
SET LRAA=$ORDER(BLRESIGR(NRESP,PATN,LRAA))
IF LRAA=""!(QFLG="Q")
QUIT
Begin DoDot:3
+13 FOR
SET LRDFN=$ORDER(BLRESIGR(NRESP,PATN,LRAA,LRDFN))
IF LRDFN=""!(QFLG="Q")
QUIT
Begin DoDot:4
+14 FOR
SET LRIDT=$ORDER(BLRESIGR(NRESP,PATN,LRAA,LRDFN,LRIDT))
IF LRIDT=""!(QFLG="Q")
QUIT
Begin DoDot:5
+15 DO NSGNRPTL
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+16 IF CNT>0
WRITE !,?10,"Number of records = ",CNT,!
+17 SET LINES=MAXLINES+10
End DoDot:1
+18 ;
+19 ; Close IO port
DO ^%ZISC
+20 ;
+21 DO BLRGPGR^BLRGMENU()
+22 ;
+23 QUIT
+24 ;
+25 ; Get Surrogate(s) Information and store in PHYSURG array
SURROGAT(RESP) ;
+1 KILL PHYSURG
+2 SET PHYSUR=0
+3 FOR
SET PHYSUR=$ORDER(^BLRALAB(9009027.1,RESP,1,PHYSUR))
IF PHYSUR=""!(PHYSUR'?.N)
QUIT
Begin DoDot:1
+4 SET SURDATES=$PIECE(^BLRALAB(9009027.1,RESP,1,PHYSUR,0),"^",2,3)
+5 SET SURBDT=$$FMTE^XLFDT($PIECE(SURDATES,"^",1),"2DZ")
+6 SET SUREDT=$$FMTE^XLFDT($PIECE(SURDATES,"^",2),"2DZ")
+7 SET PHYSURG(RESP,PHYSUR)=$PIECE($GET(^VA(200,PHYSUR,0)),"^",1)_"^"_SURBDT_"^"_SUREDT
End DoDot:1
+8 QUIT
+9 ;
+10 ; Initialize HEADER array and IO
NSGNRPTH() ;
+1 DO ESIGRPTH("REVIEWED & NOT SIGNED BY RESP PHYSICIAN")
+2 ;
+3 QUIT $$GETDEV
+4 ;
+5 ; Output line of data
NSGNRPTL ;
+1 DO ESIGBRKO
+2 ;
+3 IF LINES>MAXLINES
Begin DoDot:1
+4 DO SURINHDR(HLCNT)
+5 DO BLRGHWPN^BLRGMENU(.PG,.QFLG)
End DoDot:1
IF QFLG="Q"
QUIT
+6 ;
+7 WRITE ACCN
+8 WRITE ?19,$$FMTE^XLFDT(COLLDTT,"2MZ")
+9 WRITE ?35,$$FMTE^XLFDT(SIGNDT,"2MZ")
+10 WRITE ?51,$EXTRACT(NSIGN,1,25)
+11 WRITE !
+12 SET LINES=LINES+1
+13 SET CNT=CNT+1
+14 ;
+15 QUIT
+16 ;
+17 ; Put Surrogate(s) information in HEADER array
SURINHDR(HDCNT) ;
+1 SET HDCNT=HDCNT+1
+2 ; Clear out array
FOR J=HDCNT:1:12
KILL HEADER(J)
+3 ;
+4 SET HEADER(HDCNT)=$$CJ^XLFSTR("RESPONSIBLE PHYSICIAN:"_NRESP,IOM)
+5 SET HDCNT=HDCNT+1
+6 ;
+7 NEW RESP
+8 SET RESP=$GET(BLRESIGR(NRESP))
+9 ;
+10 ; SURROGATE Information
+11 NEW SURDATES,SURSTR,SURBDT,SUREDT
+12 SET PHYSUR=""
+13 FOR
SET PHYSUR=$ORDER(PHYSURG(RESP,PHYSUR))
IF PHYSUR=""!(QFLG="Q")
QUIT
Begin DoDot:1
+14 SET SURSTR="SURROGATE:"_$PIECE($GET(PHYSURG(RESP,PHYSUR)),"^",1)
+15 SET SURSTR=SURSTR_" BEG DATE:"_$PIECE($GET(PHYSURG(RESP,PHYSUR)),"^",2)
+16 SET SURSTR=SURSTR_" END DATE:"_$PIECE($GET(PHYSURG(RESP,PHYSUR)),"^",3)
+17 SET HEADER(HDCNT)=$$CJ^XLFSTR(SURSTR,IOM)
+18 SET HDCNT=HDCNT+1
End DoDot:1
+19 ;
+20 SET HEADER(HDCNT)=" "
+21 SET HDCNT=HDCNT+1
+22 ;
+23 SET HEADER(HDCNT)="ACC #"
+24 SET $EXTRACT(HEADER(HDCNT),20)="COLL DATE/TIME"
+25 SET $EXTRACT(HEADER(HDCNT),36)="SIGN DATE/TIME"
+26 SET $EXTRACT(HEADER(HDCNT),52)="SIGNING PHY"
+27 ;
+28 QUIT
+29 ;
SNOSIGNR ;
+1 IF $$SELCTPHY="Q"
QUIT
+2 ;
+3 DO SNSGNCOM
+4 DO NSIGNRPT
+5 QUIT
+6 ;
SNSGNCOM ;
+1 DO DATERNGE
+2 ; Clear array
KILL BLRESIGR
+3 ;
+4 ; Initialize variable
SET STATUS=2
+5 ;
+6 SET CNT=0
+7 ; E-SIG Physician
SET ESPHY=""
+8 FOR
SET ESPHY=$ORDER(SELPHYS(ESPHY))
IF ESPHY=""
QUIT
Begin DoDot:1
+9 SET NRESP=$PIECE($GET(^VA(200,ESPHY,0)),"^",1)
+10 SET BLRESIGR(NRESP)=ESPHY
+11 DO NSIGNTXN^BLRESRCD
+12 IF CNT<1
KILL BLRESIGR(NRESP)
End DoDot:1
+13 QUIT
+14 ;
DATERNGE ;
+1 WRITE !
+2 DO B^LRU
+3 SET BEGIDT=-(9999999-LRSDT)
+4 SET ENDIDT=-(9999999-(LRLDT+1))
+5 QUIT
