GMRCPSL3.m

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