GMRCPSL3 ;SLC/MA - Special Consult Reports;15-Mar-2012 10:40;PLS
;;3.0;CONSULT/REQUEST TRACKING;**23,22,1001,1003**;DEC 27, 1997;Build 14
; This routine is called by GMRCPSL2 to generate reports or
; date output.
;Modified - IHS/CIA/MGH - 11/29/2005 - Line REPORT32+58, REPORT80+58, PAGEBK32+31, PAGEBK80+30 - Changed code to use HRCN instead of SSN
; DBIA 10035 call DIQ=2 ;PATIENT FILE
; DBIA 10040 call DIQ=44 ;LOCATION FILE
; DBIA 10060 call DIQ=200 ;NEW PERSON FILE
; GMRCDT1 = Start date
; GMRCDT2 = Stop date
; GMRCBRK = Print page break between sub-totals <Y-N>
; TOTCNTR = Count for total records
; DISPLINE = ^GMR(123,,0) + FORMATED 12 NODE
REPORT32(SUBTOT,TOTCNTR,GMRCSRCH,GMRCBRK) ; Read ^TMP("GMRCRPT",$J) and format report
; The ^TMP global can be in any order but it will always have 3
; sorting parameters (PROVIDER,DATE,IEN) or (PT LOCATION,DATE,IEN)
; or (PROCEDURE TYPE,DATE,IEN)
; RPTTITL = Used to vary report title
; SRTCOMP = Used to tell when to print subtotals
; SUBTOT = Used to count subtotals
N RPTTITL,SRTCOMP,GMRCQUIT
U IO
N IEN,SRT1,SRT2,SRT3,DISPLINE,LINECNT,PAGE,RPTTITL,SUBCOMP,GMRCFRST,X
S RPTTITL=$$RPTT(GMRCSRCH)
S (LINECNT,PAGE,SUBTOT,GMRCQUIT)=0,GMRCFRST=1
S SRT1="",SRTCOMP=""
; Sorted by GMRCSRCH & date. First sort compare is just to watch
; for GMRCSRCH change to print sub-totals.
F S SRT1=$O(^TMP("GMRCRPT",$J,SRT1)) Q:'$L(SRT1) Q:GMRCQUIT D
. I SRTCOMP="" S SRTCOMP=SRT1
. I SRTCOMP'=SRT1 D
. . W !!,"SUB TOTAL= ",SUBTOT,!
. . S LINECNT=LINECNT+3
. . S SUBTOT=0
. . I GMRCBRK D PAGEBK32
. S SRT2=0
. F S SRT2=$O(^TMP("GMRCRPT",$J,SRT1,SRT2)) Q:'SRT2 Q:GMRCQUIT D
. . S SRT3=0
. . F S SRT3=$O(^TMP("GMRCRPT",$J,SRT1,SRT2,SRT3)) Q:'SRT3 Q:GMRCQUIT D
. . . S DISPLINE=^TMP("GMRCRPT",$J,SRT1,SRT2,SRT3)
. . . I GMRCFRST D PAGEBK32 ; Kick out first page header
. . . I LINECNT>IOSL D PAGEBK32
. . . I GMRCQUIT Q
. . . ;
. . . ; Start writing the print line
. . . W !,$P(DISPLINE,"|",1) ;IEN
. . . W ?11,$$FMTE^XLFDT($P(DISPLINE,"^",7),"D") ;REQ DAT
. . . ; If Provider not NULL, If IFC record Provider will be NULL
. . . I GMRCSRCH=1 D
. . . . I +$P(DISPLINE,"^",14) D
. . . . . W ?25,$E($$GET1^DIQ(200,$P(DISPLINE,"^",14),.01),1,20) ;PROVIDER
. . . . ; Provider Null and REMOTE ORDERING PROVIDER not, must be an IFC record
. . . . I '+$P(DISPLINE,"^",14),$P(DISPLINE,"^",24)'="" D
. . . . . W ?25,$E($P(DISPLINE,"^",24),1,40)
. . . . W ?48,$E($$GET1^DIQ(123.5,$P(DISPLINE,"^",5),.01),1,40) ;TO SERVICE
. . . I GMRCSRCH=2 D
. . . . ; Location not null, if null then it is a IFC record
. . . . I +$P(DISPLINE,"^",4) D
. . . . . W ?25,$E($$GET1^DIQ(44,$P(DISPLINE,"^",4),.01),1,22)
. . . . ; Location null and Ordering Facility not, IFC record
. . . . I '+$P(DISPLINE,"^",4),+$P(DISPLINE,"^",21) D
. . . . . W ?25,$E($$GET1^DIQ(4,$P(DISPLINE,"^",21),.01),1,22)
. . . . ; Location null, Ordering Facility null, Routing Facility not
. . . . ; meaning this is an IFC record
. . . . I '+$P(DISPLINE,"^",4),'+$P(DISPLINE,"^",21),+$P(DISPLINE,"^",23) D
. . . . . W ?25,$E($$GET1^DIQ(4,$P(DISPLINE,"^",23),.01),1,22)
. . . . W ?48,$E($$GET1^DIQ(123.5,$P(DISPLINE,"^",5),.01),1,40) ;TO SERVICE
. . . I GMRCSRCH=3 D
. . . . W ?25,$E($$GET1^DIQ(123.3,$P($P(DISPLINE,"^",8),";",1),.01),1,20) ;PROCEDURE
. . . . W ?48,$E($$GET1^DIQ(123.5,$P(DISPLINE,"^",5),.01),1,40) ;TO SERVICE
. . . W ?89,$E($$GET1^DIQ(2,$P(DISPLINE,"^",2),.01),1,20) ;PATIENT
. . . ;IHS/CIA/MGH Changed code to the HRCN
. . . ;W ?121,$E($$GET1^DIQ(2,$P(DISPLINE,"^",2),.09),6,9) ;SSN
. . . S X=$$HRCN^GMRCMP($P(DISPLINE,"^",2),+$G(DUZ(2)))
. . . W ?121,X ;HRCN
. . . W ?129,$$GET1^DIQ(100.01,$P(DISPLINE,"^",12),.1) ;STATUS
. . . S LINECNT=LINECNT+1,TOTCNTR=TOTCNTR+1,SUBTOT=SUBTOT+1
Q
;
REPORT80(SUBTOT,TOTCNTR,GMRCSRCH,GMRCBRK) ; Read ^TMP("GMRCRPT",$J) and format report
; The ^TMP global can be in any order but it will always have 3
; sorting parameters (PROVIDER,DATE,IEN) or (PT LOCATION,DATE,IEN)
; or (PROCEDURE TYPE,DATE,IEN)
; RPTTITL = Used to vary report title
; SRTCOMP = Used to tell when to print subtotals
; SUBTOT = Used to count subtotals
; GMRCFRST= Set to one to get first report headers to print
N RPTTITL,SRTCOMP,GMRCQUIT
U IO
N IEN,SRT1,SRT2,SRT3,DISPLINE,LINECNT,PAGE,RPTTITL,SUBCOMP,GMRCFRST
S RPTTITL=$$RPTT(GMRCSRCH)
S (LINECNT,PAGE,SUBTOT,GMRCQUIT)=0,GMRCFRST=1
S SRT1="",SRTCOMP=""
; Sorted by GMRCSRCH & date. First sort compare is just to watch
; for GMRCSRCH change to print sub-totals.
F S SRT1=$O(^TMP("GMRCRPT",$J,SRT1)) Q:'$L(SRT1) Q:GMRCQUIT D
. I SRTCOMP="" S SRTCOMP=SRT1
. I SRTCOMP'=SRT1 D
. . I (LINECNT+3)>IOSL D PAGEBK80
. . W !!,"SUB TOTAL= ",SUBTOT,!
. . S LINECNT=LINECNT+3
. . S SUBTOT=0
. . I GMRCBRK D PAGEBK80
. S SRT2=0
. F S SRT2=$O(^TMP("GMRCRPT",$J,SRT1,SRT2)) Q:'SRT2 Q:GMRCQUIT D
. . S SRT3=0
. . F S SRT3=$O(^TMP("GMRCRPT",$J,SRT1,SRT2,SRT3)) Q:'SRT3 Q:GMRCQUIT D
. . . S DISPLINE=^TMP("GMRCRPT",$J,SRT1,SRT2,SRT3)
. . . I GMRCFRST=1 D PAGEBK80 ; Kick out first page header
. . . I LINECNT>IOSL D PAGEBK80
. . . I GMRCQUIT Q
. . . ;
. . . ; STARTING WRITING THE PRINT LINE
. . . ;
. . . W !,$P(DISPLINE,"|",1) ;IEN
. . . W ?9,$P($$FMTE^XLFDT($P(DISPLINE,"^",7),2),"@",1) ;REQ DATE
. . . I GMRCSRCH=1 D
. . . . ; Provider not null, If null then it is an IFC record
. . . . I +$P(DISPLINE,"^",14) D
. . . . . W ?18,$E($$GET1^DIQ(200,$P(DISPLINE,"^",14),.01),1,16) ;PROVIDER
. . . . ; Provider null and REMOTE ORDERING PROVIDER not, this is an IFC record
. . . . I '+$P(DISPLINE,"^",14),$P(DISPLINE,"^",24)'="" D
. . . . . W ?18,$E($P(DISPLINE,"^",24),1,16)
. . . ; Location not null, If null then it is an IFC record
. . . I GMRCSRCH=2,+$P(DISPLINE,"^",4) D
. . . . W ?18,$E($$GET1^DIQ(44,$P(DISPLINE,"^",4),.01),1,16) ;LOCATION
. . . . ; Location null meaning IFC record. Use Ordering Facility
. . . I GMRCSRCH=2,$P(DISPLINE,"^",4)="",+$P(DISPLINE,"^",21) D
. . . . W ?18,$E($$GET1^DIQ(4,$P(DISPLINE,"^",21),.01),1,16) ;ORD FACILITY
. . . ; Location null, Ordering Facility null, use Routing Facilty
. . . ; Still an IFC record
. . . I GMRCSRCH=2,$P(DISPLINE,"^",4)="",'$P(DISPLINE,"^",21) D
. . . . I +$P(DISPLINE,"^",23) D
. . . . . W ?18,$E($$GET1^DIQ(4,$P(DISPLINE,"^",23),.01),1,16) ;ROUTIN FACILITY
. . . I GMRCSRCH=3 D
. . . . W ?18,$E($$GET1^DIQ(123.3,$P($P(DISPLINE,"^",8),";",1),.01),1,16) ; PROCEDURE
. . . W ?35,$E($$GET1^DIQ(2,$P(DISPLINE,"^",2),.01),1,15) ;PATIENT
. . . ;W ?56,$E($$GET1^DIQ(2,$P(DISPLINE,"^",2),.09),6,9) ;SSN
. . . ;IHS/CIA/MGH Changed code to use HRCN
. . . S X=$$HRCN^GMRCMP($P(DISPLINE,"^",2),+$G(DUZ(2)))
. . . W ?52,X ;HRCN
. . . W ?61,$E($$GET1^DIQ(123.5,$P(DISPLINE,"^",5),.01),1,15) ;TO SERVICE
. . . W ?77,$$GET1^DIQ(100.01,$P(DISPLINE,"^",12),.1) ;STATUS
. . . S LINECNT=LINECNT+1,TOTCNTR=TOTCNTR+1,SUBTOT=SUBTOT+1
Q
PAGEBK32 ;
S GMRCFRST=0
K DIR
I ($E(IOST)="C")&(IO=IO(0))&(PAGE>0) D
.S DIR(0)="E"
.W !
.D ^DIR K DIR
I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S GMRCQUIT=1 Q
W:$D(IOF) @IOF
S PAGE=PAGE+1
I $E(IOST)="C",IO=IO(0) W @IOF
E W !
N TEMPDATE,TEXTLEN,LINE
S TEMPDATE=$$NOW^XLFDT,TEMPDATE=$$FMTE^XLFDT(TEMPDATE,"P")
S TEMPDATE=TEMPDATE_" Page "_PAGE
I GMRCSRCH=1,GMRCBRK D
. W !,?6,"ORDERING PROVIDER: ",?26,SRT1
I GMRCSRCH=2,GMRCBRK D
. W !,?6,"LOCATION: ",?12,SRT1,?45
I GMRCSRCH=3,GMRCBRK D
. W !,?6,"PROCEDURE: ",?12,SRT1,?45
W !,"CONSULT LIST BY "_RPTTITL_", FOR SPECIFIED DATE(S)"
W ?97,TEMPDATE
I GMRCDT1>0 D
. W !,"FROM: ",$$FMTE^XLFDT(GMRCDT1,"D")," TO: ",$$FMTE^XLFDT(GMRCDT2-1,"D")
ELSE W !,"FROM: ALL"," TO: ALL"
W ?121,"LAST 4",?128,"CON"
W !!,"CONSULT #",?11,"REQUEST DATE"
I GMRCSRCH=1 W ?26,"ORDERING PROVIDER",?48,"TO SERVICE"
I GMRCSRCH=2 W ?26,"FROM LOCATION",?48,"TO SERVICE"
I GMRCSRCH=3 W ?26,"PROCEDURE",?48,"ASSOCIATED CONSULT SERVICE"
;IHS/CIA/MGH Changed code to use HRCN
;W ?89,"PATIENT NAME",?121,"SSN",?128,"STAT"
W ?89,"PATIENT NAME",?121,"HRCN",?128,"STAT"
S LINE="",$P(LINE,"-",132)=""
W !,LINE
S LINECNT=$S(GMRCBRK=1:8,1:7)
S LINECNT=9
Q
PAGEBK80 ;
S GMRCFRST=0
K DIR
I ($E(IOST)="C")&(IO=IO(0))&(PAGE>0) D
.S DIR(0)="E"
.W !
.D ^DIR K DIR
I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S GMRCQUIT=1 Q
W:$D(IOF) @IOF
S PAGE=PAGE+1
I $E(IOST)="C",IO=IO(0) W @IOF
E W !
N TEMPDATE,TEXTLEN,LINE
S TEMPDATE=$$NOW^XLFDT,TEMPDATE=$$FMTE^XLFDT(TEMPDATE,"P")
S TEMPDATE=TEMPDATE_" Page "_PAGE
I GMRCSRCH=1,GMRCBRK D
. W !,?6,"ORDERING PROVIDER: ",?26,SRT1,?45,TEMPDATE
I GMRCSRCH=2,GMRCBRK D
. W !,?6,"LOCATION: ",?12,SRT1,?45,TEMPDATE
I GMRCSRCH=3,GMRCBRK D
. W !,?6,"PROCEDURE: ",?12,SRT1,?45,TEMPDATE
I 'GMRCBRK W !,?45,TEMPDATE
W !,"CONSULT LIST BY "_RPTTITL_", FOR SPECIFIED DATE(S)"
I GMRCDT1>0 D
. W !,"FROM: ",$$FMTE^XLFDT(GMRCDT1,"D")," TO: ",$$FMTE^XLFDT(GMRCDT2-1,"D")
ELSE W !,"FROM: ALL"," TO: ALL"
W !!,"CONSULT",?9,"REQ DATE"
I GMRCSRCH=1 W ?18,"ORDERING PROVIDER"
I GMRCSRCH=2 W ?18,"LOCATION"
I GMRCSRCH=3 W ?18,"PROCEDURE"
;IHS/CIA/MGH Changed code to use HRCN
;W ?37,"PATIENT NAME",?56,"SSN",?61,"TO SERVICE",?77,"ST"
W ?37,"PATIENT NAME",?52,"HRCN",?61,"TO SERVICE",?77,"ST"
S LINE="",$P(LINE,"-",80)=""
W !,LINE
S LINECNT=9
Q
RPTT(GMRCSRCH) ; Title
S RPTTITL=$S(GMRCSRCH=1:"PROVIDER(S)",GMRCSRCH=2:"LOCATION(S)",1:"PROCEDURE(S)")
I GMRCSRCH'=3 D
. S RPTTITL=RPTTITL_" - "_$S(GMRCARRY(1)="ALL":"ALL ",1:"SELECTED ")_$S(GMRCARRY="L":"LOCAL",GMRCARRY="R":"REMOTE",1:"LOCAL & REMOTE")
Q RPTTITL
GMRCPSL3 ;SLC/MA - Special Consult Reports;15-Mar-2012 10:40;PLS
+1 ;;3.0;CONSULT/REQUEST TRACKING;**23,22,1001,1003**;DEC 27, 1997;Build 14
+2 ; This routine is called by GMRCPSL2 to generate reports or
+3 ; date output.
+4 ;Modified - IHS/CIA/MGH - 11/29/2005 - Line REPORT32+58, REPORT80+58, PAGEBK32+31, PAGEBK80+30 - Changed code to use HRCN instead of SSN
+5 ; DBIA 10035 call DIQ=2 ;PATIENT FILE
+6 ; DBIA 10040 call DIQ=44 ;LOCATION FILE
+7 ; DBIA 10060 call DIQ=200 ;NEW PERSON FILE
+8 ; GMRCDT1 = Start date
+9 ; GMRCDT2 = Stop date
+10 ; GMRCBRK = Print page break between sub-totals <Y-N>
+11 ; TOTCNTR = Count for total records
+12 ; DISPLINE = ^GMR(123,,0) + FORMATED 12 NODE
REPORT32(SUBTOT,TOTCNTR,GMRCSRCH,GMRCBRK) ; Read ^TMP("GMRCRPT",$J) and format report
+1 ; The ^TMP global can be in any order but it will always have 3
+2 ; sorting parameters (PROVIDER,DATE,IEN) or (PT LOCATION,DATE,IEN)
+3 ; or (PROCEDURE TYPE,DATE,IEN)
+4 ; RPTTITL = Used to vary report title
+5 ; SRTCOMP = Used to tell when to print subtotals
+6 ; SUBTOT = Used to count subtotals
+7 NEW RPTTITL,SRTCOMP,GMRCQUIT
+8 USE IO
+9 NEW IEN,SRT1,SRT2,SRT3,DISPLINE,LINECNT,PAGE,RPTTITL,SUBCOMP,GMRCFRST,X
+10 SET RPTTITL=$$RPTT(GMRCSRCH)
+11 SET (LINECNT,PAGE,SUBTOT,GMRCQUIT)=0
SET GMRCFRST=1
+12 SET SRT1=""
SET SRTCOMP=""
+13 ; Sorted by GMRCSRCH & date. First sort compare is just to watch
+14 ; for GMRCSRCH change to print sub-totals.
+15 FOR
SET SRT1=$ORDER(^TMP("GMRCRPT",$JOB,SRT1))
IF '$LENGTH(SRT1)
QUIT
IF GMRCQUIT
QUIT
Begin DoDot:1
+16 IF SRTCOMP=""
SET SRTCOMP=SRT1
+17 IF SRTCOMP'=SRT1
Begin DoDot:2
+18 WRITE !!,"SUB TOTAL= ",SUBTOT,!
+19 SET LINECNT=LINECNT+3
+20 SET SUBTOT=0
+21 IF GMRCBRK
DO PAGEBK32
End DoDot:2
+22 SET SRT2=0
+23 FOR
SET SRT2=$ORDER(^TMP("GMRCRPT",$JOB,SRT1,SRT2))
IF 'SRT2
QUIT
IF GMRCQUIT
QUIT
Begin DoDot:2
+24 SET SRT3=0
+25 FOR
SET SRT3=$ORDER(^TMP("GMRCRPT",$JOB,SRT1,SRT2,SRT3))
IF 'SRT3
QUIT
IF GMRCQUIT
QUIT
Begin DoDot:3
+26 SET DISPLINE=^TMP("GMRCRPT",$JOB,SRT1,SRT2,SRT3)
+27 ; Kick out first page header
IF GMRCFRST
DO PAGEBK32
+28 IF LINECNT>IOSL
DO PAGEBK32
+29 IF GMRCQUIT
QUIT
+30 ;
+31 ; Start writing the print line
+32 ;IEN
WRITE !,$PIECE(DISPLINE,"|",1)
+33 ;REQ DAT
WRITE ?11,$$FMTE^XLFDT($PIECE(DISPLINE,"^",7),"D")
+34 ; If Provider not NULL, If IFC record Provider will be NULL
+35 IF GMRCSRCH=1
Begin DoDot:4
+36 IF +$PIECE(DISPLINE,"^",14)
Begin DoDot:5
+37 ;PROVIDER
WRITE ?25,$EXTRACT($$GET1^DIQ(200,$PIECE(DISPLINE,"^",14),.01),1,20)
End DoDot:5
+38 ; Provider Null and REMOTE ORDERING PROVIDER not, must be an IFC record
+39 IF '+$PIECE(DISPLINE,"^",14)
IF $PIECE(DISPLINE,"^",24)'=""
Begin DoDot:5
+40 WRITE ?25,$EXTRACT($PIECE(DISPLINE,"^",24),1,40)
End DoDot:5
+41 ;TO SERVICE
WRITE ?48,$EXTRACT($$GET1^DIQ(123.5,$PIECE(DISPLINE,"^",5),.01),1,40)
End DoDot:4
+42 IF GMRCSRCH=2
Begin DoDot:4
+43 ; Location not null, if null then it is a IFC record
+44 IF +$PIECE(DISPLINE,"^",4)
Begin DoDot:5
+45 WRITE ?25,$EXTRACT($$GET1^DIQ(44,$PIECE(DISPLINE,"^",4),.01),1,22)
End DoDot:5
+46 ; Location null and Ordering Facility not, IFC record
+47 IF '+$PIECE(DISPLINE,"^",4)
IF +$PIECE(DISPLINE,"^",21)
Begin DoDot:5
+48 WRITE ?25,$EXTRACT($$GET1^DIQ(4,$PIECE(DISPLINE,"^",21),.01),1,22)
End DoDot:5
+49 ; Location null, Ordering Facility null, Routing Facility not
+50 ; meaning this is an IFC record
+51 IF '+$PIECE(DISPLINE,"^",4)
IF '+$PIECE(DISPLINE,"^",21)
IF +$PIECE(DISPLINE,"^",23)
Begin DoDot:5
+52 WRITE ?25,$EXTRACT($$GET1^DIQ(4,$PIECE(DISPLINE,"^",23),.01),1,22)
End DoDot:5
+53 ;TO SERVICE
WRITE ?48,$EXTRACT($$GET1^DIQ(123.5,$PIECE(DISPLINE,"^",5),.01),1,40)
End DoDot:4
+54 IF GMRCSRCH=3
Begin DoDot:4
+55 ;PROCEDURE
WRITE ?25,$EXTRACT($$GET1^DIQ(123.3,$PIECE($PIECE(DISPLINE,"^",8),";",1),.01),1,20)
+56 ;TO SERVICE
WRITE ?48,$EXTRACT($$GET1^DIQ(123.5,$PIECE(DISPLINE,"^",5),.01),1,40)
End DoDot:4
+57 ;PATIENT
WRITE ?89,$EXTRACT($$GET1^DIQ(2,$PIECE(DISPLINE,"^",2),.01),1,20)
+58 ;IHS/CIA/MGH Changed code to the HRCN
+59 ;W ?121,$E($$GET1^DIQ(2,$P(DISPLINE,"^",2),.09),6,9) ;SSN
+60 SET X=$$HRCN^GMRCMP($PIECE(DISPLINE,"^",2),+$GET(DUZ(2)))
+61 ;HRCN
WRITE ?121,X
+62 ;STATUS
WRITE ?129,$$GET1^DIQ(100.01,$PIECE(DISPLINE,"^",12),.1)
+63 SET LINECNT=LINECNT+1
SET TOTCNTR=TOTCNTR+1
SET SUBTOT=SUBTOT+1
End DoDot:3
End DoDot:2
End DoDot:1
+64 QUIT
+65 ;
REPORT80(SUBTOT,TOTCNTR,GMRCSRCH,GMRCBRK) ; Read ^TMP("GMRCRPT",$J) and format report
+1 ; The ^TMP global can be in any order but it will always have 3
+2 ; sorting parameters (PROVIDER,DATE,IEN) or (PT LOCATION,DATE,IEN)
+3 ; or (PROCEDURE TYPE,DATE,IEN)
+4 ; RPTTITL = Used to vary report title
+5 ; SRTCOMP = Used to tell when to print subtotals
+6 ; SUBTOT = Used to count subtotals
+7 ; GMRCFRST= Set to one to get first report headers to print
+8 NEW RPTTITL,SRTCOMP,GMRCQUIT
+9 USE IO
+10 NEW IEN,SRT1,SRT2,SRT3,DISPLINE,LINECNT,PAGE,RPTTITL,SUBCOMP,GMRCFRST
+11 SET RPTTITL=$$RPTT(GMRCSRCH)
+12 SET (LINECNT,PAGE,SUBTOT,GMRCQUIT)=0
SET GMRCFRST=1
+13 SET SRT1=""
SET SRTCOMP=""
+14 ; Sorted by GMRCSRCH & date. First sort compare is just to watch
+15 ; for GMRCSRCH change to print sub-totals.
+16 FOR
SET SRT1=$ORDER(^TMP("GMRCRPT",$JOB,SRT1))
IF '$LENGTH(SRT1)
QUIT
IF GMRCQUIT
QUIT
Begin DoDot:1
+17 IF SRTCOMP=""
SET SRTCOMP=SRT1
+18 IF SRTCOMP'=SRT1
Begin DoDot:2
+19 IF (LINECNT+3)>IOSL
DO PAGEBK80
+20 WRITE !!,"SUB TOTAL= ",SUBTOT,!
+21 SET LINECNT=LINECNT+3
+22 SET SUBTOT=0
+23 IF GMRCBRK
DO PAGEBK80
End DoDot:2
+24 SET SRT2=0
+25 FOR
SET SRT2=$ORDER(^TMP("GMRCRPT",$JOB,SRT1,SRT2))
IF 'SRT2
QUIT
IF GMRCQUIT
QUIT
Begin DoDot:2
+26 SET SRT3=0
+27 FOR
SET SRT3=$ORDER(^TMP("GMRCRPT",$JOB,SRT1,SRT2,SRT3))
IF 'SRT3
QUIT
IF GMRCQUIT
QUIT
Begin DoDot:3
+28 SET DISPLINE=^TMP("GMRCRPT",$JOB,SRT1,SRT2,SRT3)
+29 ; Kick out first page header
IF GMRCFRST=1
DO PAGEBK80
+30 IF LINECNT>IOSL
DO PAGEBK80
+31 IF GMRCQUIT
QUIT
+32 ;
+33 ; STARTING WRITING THE PRINT LINE
+34 ;
+35 ;IEN
WRITE !,$PIECE(DISPLINE,"|",1)
+36 ;REQ DATE
WRITE ?9,$PIECE($$FMTE^XLFDT($PIECE(DISPLINE,"^",7),2),"@",1)
+37 IF GMRCSRCH=1
Begin DoDot:4
+38 ; Provider not null, If null then it is an IFC record
+39 IF +$PIECE(DISPLINE,"^",14)
Begin DoDot:5
+40 ;PROVIDER
WRITE ?18,$EXTRACT($$GET1^DIQ(200,$PIECE(DISPLINE,"^",14),.01),1,16)
End DoDot:5
+41 ; Provider null and REMOTE ORDERING PROVIDER not, this is an IFC record
+42 IF '+$PIECE(DISPLINE,"^",14)
IF $PIECE(DISPLINE,"^",24)'=""
Begin DoDot:5
+43 WRITE ?18,$EXTRACT($PIECE(DISPLINE,"^",24),1,16)
End DoDot:5
End DoDot:4
+44 ; Location not null, If null then it is an IFC record
+45 IF GMRCSRCH=2
IF +$PIECE(DISPLINE,"^",4)
Begin DoDot:4
+46 ;LOCATION
WRITE ?18,$EXTRACT($$GET1^DIQ(44,$PIECE(DISPLINE,"^",4),.01),1,16)
+47 ; Location null meaning IFC record. Use Ordering Facility
End DoDot:4
+48 IF GMRCSRCH=2
IF $PIECE(DISPLINE,"^",4)=""
IF +$PIECE(DISPLINE,"^",21)
Begin DoDot:4
+49 ;ORD FACILITY
WRITE ?18,$EXTRACT($$GET1^DIQ(4,$PIECE(DISPLINE,"^",21),.01),1,16)
End DoDot:4
+50 ; Location null, Ordering Facility null, use Routing Facilty
+51 ; Still an IFC record
+52 IF GMRCSRCH=2
IF $PIECE(DISPLINE,"^",4)=""
IF '$PIECE(DISPLINE,"^",21)
Begin DoDot:4
+53 IF +$PIECE(DISPLINE,"^",23)
Begin DoDot:5
+54 ;ROUTIN FACILITY
WRITE ?18,$EXTRACT($$GET1^DIQ(4,$PIECE(DISPLINE,"^",23),.01),1,16)
End DoDot:5
End DoDot:4
+55 IF GMRCSRCH=3
Begin DoDot:4
+56 ; PROCEDURE
WRITE ?18,$EXTRACT($$GET1^DIQ(123.3,$PIECE($PIECE(DISPLINE,"^",8),";",1),.01),1,16)
End DoDot:4
+57 ;PATIENT
WRITE ?35,$EXTRACT($$GET1^DIQ(2,$PIECE(DISPLINE,"^",2),.01),1,15)
+58 ;W ?56,$E($$GET1^DIQ(2,$P(DISPLINE,"^",2),.09),6,9) ;SSN
+59 ;IHS/CIA/MGH Changed code to use HRCN
+60 SET X=$$HRCN^GMRCMP($PIECE(DISPLINE,"^",2),+$GET(DUZ(2)))
+61 ;HRCN
WRITE ?52,X
+62 ;TO SERVICE
WRITE ?61,$EXTRACT($$GET1^DIQ(123.5,$PIECE(DISPLINE,"^",5),.01),1,15)
+63 ;STATUS
WRITE ?77,$$GET1^DIQ(100.01,$PIECE(DISPLINE,"^",12),.1)
+64 SET LINECNT=LINECNT+1
SET TOTCNTR=TOTCNTR+1
SET SUBTOT=SUBTOT+1
End DoDot:3
End DoDot:2
End DoDot:1
+65 QUIT
PAGEBK32 ;
+1 SET GMRCFRST=0
+2 KILL DIR
+3 IF ($EXTRACT(IOST)="C")&(IO=IO(0))&(PAGE>0)
Begin DoDot:1
+4 SET DIR(0)="E"
+5 WRITE !
+6 DO ^DIR
KILL DIR
End DoDot:1
+7 IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIROUT))
SET GMRCQUIT=1
QUIT
+8 IF $DATA(IOF)
WRITE @IOF
+9 SET PAGE=PAGE+1
+10 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE @IOF
+11 IF '$TEST
WRITE !
+12 NEW TEMPDATE,TEXTLEN,LINE
+13 SET TEMPDATE=$$NOW^XLFDT
SET TEMPDATE=$$FMTE^XLFDT(TEMPDATE,"P")
+14 SET TEMPDATE=TEMPDATE_" Page "_PAGE
+15 IF GMRCSRCH=1
IF GMRCBRK
Begin DoDot:1
+16 WRITE !,?6,"ORDERING PROVIDER: ",?26,SRT1
End DoDot:1
+17 IF GMRCSRCH=2
IF GMRCBRK
Begin DoDot:1
+18 WRITE !,?6,"LOCATION: ",?12,SRT1,?45
End DoDot:1
+19 IF GMRCSRCH=3
IF GMRCBRK
Begin DoDot:1
+20 WRITE !,?6,"PROCEDURE: ",?12,SRT1,?45
End DoDot:1
+21 WRITE !,"CONSULT LIST BY "_RPTTITL_", FOR SPECIFIED DATE(S)"
+22 WRITE ?97,TEMPDATE
+23 IF GMRCDT1>0
Begin DoDot:1
+24 WRITE !,"FROM: ",$$FMTE^XLFDT(GMRCDT1,"D")," TO: ",$$FMTE^XLFDT(GMRCDT2-1,"D")
End DoDot:1
+25 IF '$TEST
WRITE !,"FROM: ALL"," TO: ALL"
+26 WRITE ?121,"LAST 4",?128,"CON"
+27 WRITE !!,"CONSULT #",?11,"REQUEST DATE"
+28 IF GMRCSRCH=1
WRITE ?26,"ORDERING PROVIDER",?48,"TO SERVICE"
+29 IF GMRCSRCH=2
WRITE ?26,"FROM LOCATION",?48,"TO SERVICE"
+30 IF GMRCSRCH=3
WRITE ?26,"PROCEDURE",?48,"ASSOCIATED CONSULT SERVICE"
+31 ;IHS/CIA/MGH Changed code to use HRCN
+32 ;W ?89,"PATIENT NAME",?121,"SSN",?128,"STAT"
+33 WRITE ?89,"PATIENT NAME",?121,"HRCN",?128,"STAT"
+34 SET LINE=""
SET $PIECE(LINE,"-",132)=""
+35 WRITE !,LINE
+36 SET LINECNT=$SELECT(GMRCBRK=1:8,1:7)
+37 SET LINECNT=9
+38 QUIT
PAGEBK80 ;
+1 SET GMRCFRST=0
+2 KILL DIR
+3 IF ($EXTRACT(IOST)="C")&(IO=IO(0))&(PAGE>0)
Begin DoDot:1
+4 SET DIR(0)="E"
+5 WRITE !
+6 DO ^DIR
KILL DIR
End DoDot:1
+7 IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIROUT))
SET GMRCQUIT=1
QUIT
+8 IF $DATA(IOF)
WRITE @IOF
+9 SET PAGE=PAGE+1
+10 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE @IOF
+11 IF '$TEST
WRITE !
+12 NEW TEMPDATE,TEXTLEN,LINE
+13 SET TEMPDATE=$$NOW^XLFDT
SET TEMPDATE=$$FMTE^XLFDT(TEMPDATE,"P")
+14 SET TEMPDATE=TEMPDATE_" Page "_PAGE
+15 IF GMRCSRCH=1
IF GMRCBRK
Begin DoDot:1
+16 WRITE !,?6,"ORDERING PROVIDER: ",?26,SRT1,?45,TEMPDATE
End DoDot:1
+17 IF GMRCSRCH=2
IF GMRCBRK
Begin DoDot:1
+18 WRITE !,?6,"LOCATION: ",?12,SRT1,?45,TEMPDATE
End DoDot:1
+19 IF GMRCSRCH=3
IF GMRCBRK
Begin DoDot:1
+20 WRITE !,?6,"PROCEDURE: ",?12,SRT1,?45,TEMPDATE
End DoDot:1
+21 IF 'GMRCBRK
WRITE !,?45,TEMPDATE
+22 WRITE !,"CONSULT LIST BY "_RPTTITL_", FOR SPECIFIED DATE(S)"
+23 IF GMRCDT1>0
Begin DoDot:1
+24 WRITE !,"FROM: ",$$FMTE^XLFDT(GMRCDT1,"D")," TO: ",$$FMTE^XLFDT(GMRCDT2-1,"D")
End DoDot:1
+25 IF '$TEST
WRITE !,"FROM: ALL"," TO: ALL"
+26 WRITE !!,"CONSULT",?9,"REQ DATE"
+27 IF GMRCSRCH=1
WRITE ?18,"ORDERING PROVIDER"
+28 IF GMRCSRCH=2
WRITE ?18,"LOCATION"
+29 IF GMRCSRCH=3
WRITE ?18,"PROCEDURE"
+30 ;IHS/CIA/MGH Changed code to use HRCN
+31 ;W ?37,"PATIENT NAME",?56,"SSN",?61,"TO SERVICE",?77,"ST"
+32 WRITE ?37,"PATIENT NAME",?52,"HRCN",?61,"TO SERVICE",?77,"ST"
+33 SET LINE=""
SET $PIECE(LINE,"-",80)=""
+34 WRITE !,LINE
+35 SET LINECNT=9
+36 QUIT
RPTT(GMRCSRCH) ; Title
+1 SET RPTTITL=$SELECT(GMRCSRCH=1:"PROVIDER(S)",GMRCSRCH=2:"LOCATION(S)",1:"PROCEDURE(S)")
+2 IF GMRCSRCH'=3
Begin DoDot:1
+3 SET RPTTITL=RPTTITL_" - "_$SELECT(GMRCARRY(1)="ALL":"ALL ",1:"SELECTED ")_$SELECT(GMRCARRY="L":"LOCAL",GMRCARRY="R":"REMOTE",1:"LOCAL & REMOTE")
End DoDot:1
+4 QUIT RPTTITL
