Routine: GMRCAD

GMRCAD ;ABV/PIJ - Consults Report by Released by Policy. Patch GMRC*3.0*107 ;7/5/18 07:36

 ;;3.0;CONSULT/REQUEST TRACKING;**107**;DEC 27, 1997;Build 27

 ; LOCAL VISTA REPORT BY CONSULT

 ; Screen Title: Admin Released Consults-Title

EN ; -- main entry point for GMRC RPT ADMIN RELEASE CONSULT

 N GMRCDT1,GMRCDT2,GMRCEDT1,GMRCEDT2

 D EN^VALM("GMRC RPT ADMIN RELEASE CONSULT")

EN1 ;Ask for date range

 S DIR(0)="DA",DIR("A")="Enter Consult Released Starting Date: "

 D ^DIR

 I $D(DUOUT)!($D(DTOUT)) S GMRCQUT=1 Q

 S GMRCDT1=+Y I 'GMRCDT1 G EN1

 W "  (",$$FMTE^XLFDT(GMRCDT1)_")"

 K DIR

 S DIR(0)="DA",DIR("A")="Enter Consult Released Ending Date: "

 D ^DIR

 I $D(DTOUT)!($D(DUOUT)) K GMRCDT1 S GMRCQUT=1 G EXIT

 I +Y<GMRCDT1 W !!,$C(7),"Ending Date Can Not Be Before Starting Date.",! G EN1

 I $G(GMRCDT2)="" S GMRCDT2=+Y

 W "  (",$$FMTE^XLFDT(GMRCDT2)_")"

 ; Retrieve External Date

 D LISTDATE^GMRCSTU1(GMRCDT1,GMRCDT2,.GMRCEDT1,.GMRCEDT2)

HDR ; -- header code

 N GMRCSITE

 S GMRCSITE=$P($$SITE^VASITE(),U,2)

 S VALMHDR(1)="VAMC: "_GMRCSITE

 S VALMHDR(2)="From: "_$G(GMRCEDT1)_"   To: "_$G(GMRCEDT2)

BLDLIST ; -- init variables and list array

 N I,IENS,LINE,ORDITEM,ORIEN,RELBY

 N FMRELDT

 S (FMRELDT,ORIEN,LINEVAR)=""

 S LINECNT=0

 K ^TMP("GMRCAD",$J)

 F  S FMRELDT=$O(^OR(100,"AADMINKEY",FMRELDT)) Q:FMRELDT=""  D

 . F I=GMRCDT1:1:GMRCDT2 I $P(I,".",1)=$P(FMRELDT,".",1) D

 .. ;

 .. F  S ORIEN=$O(^OR(100,"AADMINKEY",FMRELDT,"Y",ORIEN)) Q:ORIEN=""  D

 ... S IENS="1,"_ORIEN

 ... S ORDITEM=$$GET1^DIQ(100.001,IENS,.01) ; Orderable Item

 ... I '$D(^TMP("GMRCAD",$J,ORDITEM)) S ^TMP("GMRCAD",$J,ORDITEM)=0

 ... S ^TMP("GMRCAD",$J,ORDITEM)=^TMP("GMRCAD",$J,ORDITEM)+1

 ... ;

 ... S RELBY=$$GET1^DIQ(100.008,IENS,17)    ; Released by

 ... I '$D(^TMP("GMRCAD",$J,ORDITEM,RELBY)) S ^TMP("GMRCAD",$J,ORDITEM,RELBY)=0

 ... S ^TMP("GMRCAD",$J,ORDITEM,RELBY)=^TMP("GMRCAD",$J,ORDITEM,RELBY)+1

INIT ;

 K ^TMP("VALMAR",$J)

 N DTOUT,DIR,DUOUT,DIRUT,GMRCQUT,X,Y,TOTAL

 S (GMRCDT1,GMRCDT2,GMRCEDT1,GMRCEDT2,GMRCQUT)=""

 S (LINECNT,TOTAL,VALMCNT)=0

 D EN1

 I GMRCQUT S VALMQUIT="",VALMBCK="Q" Q

 D BLDLIST ;build the list for List Manager

 N NUM,ORDITEM,RELBY

 S ORDITEM=""

 S (LINE,LINECNT,NUM)=0

 S LINEVAR=""

 F  S ORDITEM=$O(^TMP("GMRCAD",$J,ORDITEM)) Q:ORDITEM=""  D

 . S LINECNT=LINECNT+1

 . S LINEVAR=$$SETFLD^VALM1(ORDITEM,LINEVAR,"USER")

. ;

 . S NUM=^TMP("GMRCAD",$J,ORDITEM)

 . S TOTAL=TOTAL+NUM

 . S LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")

 . D VALM10(LINEVAR)  ; Print first group

. ;

 . S RELBY=""

 . F  S RELBY=$O(^TMP("GMRCAD",$J,ORDITEM,RELBY)) D:RELBY="" VALM10("") Q:RELBY=""  D

 .. S LINEVAR=$$SETFLD^VALM1("  "_RELBY,LINEVAR,"USER")

 .. ;

 .. S NUM=^TMP("GMRCAD",$J,ORDITEM,RELBY)

 .. S LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")

 .. ;

 .. D VALM10(LINEVAR)

 D VALM10("") ; Enter blank line

 S LINEVAR="GRAND TOTAL "_TOTAL

 D SET^VALM10(LINE,LINEVAR)

 S VALMBCK="R"

 K ^TMP("GMRCAD",$J)

 K LINECNT

VALM10(LINEVAR) ;

 S LINE=LINE+1

 D SET^VALM10(LINE,LINEVAR)

 S VALMCNT=LINE

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

EXIT ; -- exit code

 K ^TMP("VALMAR",$J)

EXPND ; -- expand code

DTRES ;Restore old date in case user '^' out.

 I $D(GMRCDTS1) S GMRCDT1=GMRCDTS1

 I $D(GMRCDTS2) S GMRCDT2=GMRCDTS2

 K GMRCDTS1,GMRCDTS2

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCAD   3480     printed  Mar 13, 2025@20:49:37                                                                                                                                                                                                      Page 2

GMRCAD    ;ABV/PIJ - Consults Report by Released by Policy. Patch GMRC*3.0*107 ;7/5/18 07:36

 +1       ;;3.0;CONSULT/REQUEST TRACKING;**107**;DEC 27, 1997;Build 27

 +2       ;

 +3       ; LOCAL VISTA REPORT BY CONSULT

 +4       ;

 +5       ; Screen Title: Admin Released Consults-Title

 +6       ;

EN        ; -- main entry point for GMRC RPT ADMIN RELEASE CONSULT

 +1       ;

 +2        NEW GMRCDT1,GMRCDT2,GMRCEDT1,GMRCEDT2

 +3       ;

 +4        DO EN^VALM("GMRC RPT ADMIN RELEASE CONSULT")

 +5        QUIT

 +6       ;

EN1       ;Ask for date range

 +1       ;

 +2        SET DIR(0)="DA"

           SET DIR("A")="Enter Consult Released Starting Date: "

 +3        DO ^DIR

 +4        IF $DATA(DUOUT)!($DATA(DTOUT))

               SET GMRCQUT=1

               QUIT

 +5        SET GMRCDT1=+Y

           IF 'GMRCDT1

               GOTO EN1

 +6        WRITE "  (",$$FMTE^XLFDT(GMRCDT1)_")"

 +7       ;

 +8        KILL DIR

 +9        SET DIR(0)="DA"

           SET DIR("A")="Enter Consult Released Ending Date: "

 +10       DO ^DIR

 +11       IF $DATA(DTOUT)!($DATA(DUOUT))

               KILL GMRCDT1

               SET GMRCQUT=1

               GOTO EXIT

 +12       IF +Y<GMRCDT1

               WRITE !!,$CHAR(7),"Ending Date Can Not Be Before Starting Date.",!

               GOTO EN1

 +13       IF $GET(GMRCDT2)=""

               SET GMRCDT2=+Y

 +14       WRITE "  (",$$FMTE^XLFDT(GMRCDT2)_")"

 +15      ;

 +16      ; Retrieve External Date

 +17       DO LISTDATE^GMRCSTU1(GMRCDT1,GMRCDT2,.GMRCEDT1,.GMRCEDT2)

 +18      ;

 +19       QUIT

 +20      ;

HDR       ; -- header code

 +1        NEW GMRCSITE

 +2        SET GMRCSITE=$PIECE($$SITE^VASITE(),U,2)

 +3        SET VALMHDR(1)="VAMC: "_GMRCSITE

 +4        SET VALMHDR(2)="From: "_$GET(GMRCEDT1)_"   To: "_$GET(GMRCEDT2)

 +5        QUIT

 +6       ;

BLDLIST   ; -- init variables and list array

 +1        NEW I,IENS,LINE,ORDITEM,ORIEN,RELBY

 +2        NEW FMRELDT

 +3       ;

 +4        SET (FMRELDT,ORIEN,LINEVAR)=""

 +5        SET LINECNT=0

 +6       ;

 +7        KILL ^TMP("GMRCAD",$JOB)

 +8       ;

 +9        FOR

               SET FMRELDT=$ORDER(^OR(100,"AADMINKEY",FMRELDT))

               if FMRELDT=""

                   QUIT

               Begin DoDot:1

 +10               FOR I=GMRCDT1:1:GMRCDT2

                       IF $PIECE(I,".",1)=$PIECE(FMRELDT,".",1)

                           Begin DoDot:2

 +11      ;

 +12                           FOR

                                   SET ORIEN=$ORDER(^OR(100,"AADMINKEY",FMRELDT,"Y",ORIEN))

                                   if ORIEN=""

                                       QUIT

                                   Begin DoDot:3

 +13                                   SET IENS="1,"_ORIEN

 +14      ; Orderable Item

                                       SET ORDITEM=$$GET1^DIQ(100.001,IENS,.01)

 +15                                   IF '$DATA(^TMP("GMRCAD",$JOB,ORDITEM))

                                           SET ^TMP("GMRCAD",$JOB,ORDITEM)=0

 +16                                   SET ^TMP("GMRCAD",$JOB,ORDITEM)=^TMP("GMRCAD",$JOB,ORDITEM)+1

 +17      ;

 +18      ; Released by

                                       SET RELBY=$$GET1^DIQ(100.008,IENS,17)

 +19                                   IF '$DATA(^TMP("GMRCAD",$JOB,ORDITEM,RELBY))

                                           SET ^TMP("GMRCAD",$JOB,ORDITEM,RELBY)=0

 +20                                   SET ^TMP("GMRCAD",$JOB,ORDITEM,RELBY)=^TMP("GMRCAD",$JOB,ORDITEM,RELBY)+1

                                   End DoDot:3

                           End DoDot:2

               End DoDot:1

 +21       QUIT

 +22      ;

INIT      ;

 +1        KILL ^TMP("VALMAR",$JOB)

 +2        NEW DTOUT,DIR,DUOUT,DIRUT,GMRCQUT,X,Y,TOTAL

 +3       ;

 +4        SET (GMRCDT1,GMRCDT2,GMRCEDT1,GMRCEDT2,GMRCQUT)=""

 +5        SET (LINECNT,TOTAL,VALMCNT)=0

 +6       ;

 +7        DO EN1

 +8        IF GMRCQUT

               SET VALMQUIT=""

               SET VALMBCK="Q"

               QUIT

 +9       ;

 +10      ;build the list for List Manager

           DO BLDLIST

 +11       NEW NUM,ORDITEM,RELBY

 +12       SET ORDITEM=""

 +13       SET (LINE,LINECNT,NUM)=0

 +14      ;

 +15       SET LINEVAR=""

 +16      ;

 +17       FOR

               SET ORDITEM=$ORDER(^TMP("GMRCAD",$JOB,ORDITEM))

               if ORDITEM=""

                   QUIT

               Begin DoDot:1

 +18               SET LINECNT=LINECNT+1

 +19               SET LINEVAR=$$SETFLD^VALM1(ORDITEM,LINEVAR,"USER")

 +20      ;

 +21               SET NUM=^TMP("GMRCAD",$JOB,ORDITEM)

 +22               SET TOTAL=TOTAL+NUM

 +23               SET LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")

 +24      ; Print first group

                   DO VALM10(LINEVAR)

 +25      ;

 +26               SET RELBY=""

 +27               FOR

                       SET RELBY=$ORDER(^TMP("GMRCAD",$JOB,ORDITEM,RELBY))

                       if RELBY=""

                           DO VALM10("")

                       if RELBY=""

                           QUIT

                       Begin DoDot:2

 +28                       SET LINEVAR=$$SETFLD^VALM1("  "_RELBY,LINEVAR,"USER")

 +29      ;

 +30                       SET NUM=^TMP("GMRCAD",$JOB,ORDITEM,RELBY)

 +31                       SET LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")

 +32      ;

 +33                       DO VALM10(LINEVAR)

                       End DoDot:2

               End DoDot:1

 +34      ;

 +35      ; Enter blank line

           DO VALM10("")

 +36       SET LINEVAR="GRAND TOTAL "_TOTAL

 +37       DO SET^VALM10(LINE,LINEVAR)

 +38      ;

 +39       SET VALMBCK="R"

 +40      ;

 +41       KILL ^TMP("GMRCAD",$JOB)

 +42       KILL LINECNT

 +43       QUIT

 +44      ;

VALM10(LINEVAR) ;

 +1        SET LINE=LINE+1

 +2        DO SET^VALM10(LINE,LINEVAR)

 +3        SET VALMCNT=LINE

 +4        QUIT

 +5       ;

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT

 +3       ;

EXIT      ; -- exit code

 +1        KILL ^TMP("VALMAR",$JOB)

 +2        QUIT

 +3       ;

EXPND     ; -- expand code

 +1        QUIT

 +2       ;

DTRES     ;Restore old date in case user '^' out.

 +1        IF $DATA(GMRCDTS1)

               SET GMRCDT1=GMRCDTS1

 +2        IF $DATA(GMRCDTS2)

               SET GMRCDT2=GMRCDTS2

 +3        KILL GMRCDTS1,GMRCDTS2

 +4        QUIT

GMRCAD.m