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")
Q
;
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)
;
Q
;
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)
Q
;
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
Q
;
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
Q
;
VALM10(LINEVAR) ;
S LINE=LINE+1
D SET^VALM10(LINE,LINEVAR)
S VALMCNT=LINE
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("VALMAR",$J)
Q
;
EXPND ; -- expand code
Q
;
DTRES ;Restore old date in case user '^' out.
I $D(GMRCDTS1) S GMRCDT1=GMRCDTS1
I $D(GMRCDTS2) S GMRCDT2=GMRCDTS2
K GMRCDTS1,GMRCDTS2
Q
--- 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
