GMRCADU ;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 USER
;
; Screen Title: Admin Released Consults-User
;
EN ; -- main entry point for GMRC RPT ADMIN RELEASE CONSULT
;
N GMRCEDT1,GMRCEDT2
;
D EN^VALM("GMRC RPT ADMIN REL CONS USER")
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 FMRELDT,I,IENS,LINE,ORDITEM,ORIEN,RELBY
S (FMRELDT,ORIEN,LINEVAR)=""
S LINECNT=0
;
K ^TMP("GMRCADU",$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
.. ; Orderable Item
.. F S ORIEN=$O(^OR(100,"AADMINKEY",FMRELDT,"Y",ORIEN)) Q:ORIEN="" D
... S IENS="1,"_ORIEN
... ;
... ; Released By
... S RELBY=$$GET1^DIQ(100.008,IENS,17) ; Released by
... I '$D(^TMP("GMRCADU",$J,RELBY)) S ^TMP("GMRCADU",$J,RELBY)=0
... S ^TMP("GMRCADU",$J,RELBY)=^TMP("GMRCADU",$J,RELBY)+1
... ;
... S ORDITEM=$$GET1^DIQ(100.001,IENS,.01) ; Orderable Item
... I '$D(^TMP("GMRCADU",$J,RELBY,ORDITEM)) S ^TMP("GMRCADU",$J,RELBY,ORDITEM)=0
... S ^TMP("GMRCADU",$J,RELBY,ORDITEM)=^TMP("GMRCADU",$J,RELBY,ORDITEM)+1
Q
;
INIT ;
K ^TMP("VALMAR",$J)
N DTOUT,DIR,DUOUT,DIRUT,GMRCQUT,X,Y,TOTAL
N GMRCDT1,GMRCDT2,LINECNT
;
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 (LINE,LINECNT,NUM)=0
;
S LINEVAR=""
;
S RELBY=""
F S RELBY=$O(^TMP("GMRCADU",$J,RELBY)) Q:RELBY="" D
. S LINECNT=LINECNT+1
. S LINEVAR=$$SETFLD^VALM1(RELBY,LINEVAR,"ORDITEM")
. ;
. S NUM=^TMP("GMRCADU",$J,RELBY)
. S TOTAL=TOTAL+NUM
. S LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")
. D VALM10(LINEVAR) ; Print first group
. ;
. S ORDITEM=""
. F S ORDITEM=$O(^TMP("GMRCADU",$J,RELBY,ORDITEM)) D:ORDITEM="" VALM10("") Q:ORDITEM="" D
.. S LINEVAR=$$SETFLD^VALM1(" "_ORDITEM,LINEVAR,"ORDITEM")
.. ;
.. S NUM=^TMP("GMRCADU",$J,RELBY,ORDITEM)
.. 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("GMRCADU",$J)
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[HGMRCADU 3521 printed Dec 13, 2024@01:45:01 Page 2
GMRCADU ;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 USER
+4 ;
+5 ; Screen Title: Admin Released Consults-User
+6 ;
EN ; -- main entry point for GMRC RPT ADMIN RELEASE CONSULT
+1 ;
+2 NEW GMRCEDT1,GMRCEDT2
+3 ;
+4 DO EN^VALM("GMRC RPT ADMIN REL CONS USER")
+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 FMRELDT,I,IENS,LINE,ORDITEM,ORIEN,RELBY
+2 SET (FMRELDT,ORIEN,LINEVAR)=""
+3 SET LINECNT=0
+4 ;
+5 KILL ^TMP("GMRCADU",$JOB)
+6 ;
+7 FOR
SET FMRELDT=$ORDER(^OR(100,"AADMINKEY",FMRELDT))
if FMRELDT=""
QUIT
Begin DoDot:1
+8 FOR I=GMRCDT1:1:GMRCDT2
IF $PIECE(I,".",1)=$PIECE(FMRELDT,".",1)
Begin DoDot:2
+9 ; Orderable Item
+10 FOR
SET ORIEN=$ORDER(^OR(100,"AADMINKEY",FMRELDT,"Y",ORIEN))
if ORIEN=""
QUIT
Begin DoDot:3
+11 SET IENS="1,"_ORIEN
+12 ;
+13 ; Released By
+14 ; Released by
SET RELBY=$$GET1^DIQ(100.008,IENS,17)
+15 IF '$DATA(^TMP("GMRCADU",$JOB,RELBY))
SET ^TMP("GMRCADU",$JOB,RELBY)=0
+16 SET ^TMP("GMRCADU",$JOB,RELBY)=^TMP("GMRCADU",$JOB,RELBY)+1
+17 ;
+18 ; Orderable Item
SET ORDITEM=$$GET1^DIQ(100.001,IENS,.01)
+19 IF '$DATA(^TMP("GMRCADU",$JOB,RELBY,ORDITEM))
SET ^TMP("GMRCADU",$JOB,RELBY,ORDITEM)=0
+20 SET ^TMP("GMRCADU",$JOB,RELBY,ORDITEM)=^TMP("GMRCADU",$JOB,RELBY,ORDITEM)+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 NEW GMRCDT1,GMRCDT2,LINECNT
+4 ;
+5 SET (GMRCDT1,GMRCDT2,GMRCEDT1,GMRCEDT2,GMRCQUT)=""
+6 SET (LINECNT,TOTAL,VALMCNT)=0
+7 ;
+8 DO EN1
+9 IF GMRCQUT
SET VALMQUIT=""
SET VALMBCK="Q"
QUIT
+10 ;
+11 ;build the list for List Manager
DO BLDLIST
+12 NEW NUM,ORDITEM,RELBY
+13 SET (LINE,LINECNT,NUM)=0
+14 ;
+15 SET LINEVAR=""
+16 ;
+17 SET RELBY=""
+18 FOR
SET RELBY=$ORDER(^TMP("GMRCADU",$JOB,RELBY))
if RELBY=""
QUIT
Begin DoDot:1
+19 SET LINECNT=LINECNT+1
+20 SET LINEVAR=$$SETFLD^VALM1(RELBY,LINEVAR,"ORDITEM")
+21 ;
+22 SET NUM=^TMP("GMRCADU",$JOB,RELBY)
+23 SET TOTAL=TOTAL+NUM
+24 SET LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")
+25 ; Print first group
DO VALM10(LINEVAR)
+26 ;
+27 SET ORDITEM=""
+28 FOR
SET ORDITEM=$ORDER(^TMP("GMRCADU",$JOB,RELBY,ORDITEM))
if ORDITEM=""
DO VALM10("")
if ORDITEM=""
QUIT
Begin DoDot:2
+29 SET LINEVAR=$$SETFLD^VALM1(" "_ORDITEM,LINEVAR,"ORDITEM")
+30 ;
+31 SET NUM=^TMP("GMRCADU",$JOB,RELBY,ORDITEM)
+32 SET LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")
+33 ;
+34 DO VALM10(LINEVAR)
End DoDot:2
End DoDot:1
+35 ;
+36 ; Enter blank line
DO VALM10("")
+37 SET LINEVAR="GRAND TOTAL "_TOTAL
+38 DO SET^VALM10(LINE,LINEVAR)
+39 ;
+40 SET VALMBCK="R"
+41 ;
+42 KILL ^TMP("GMRCADU",$JOB)
+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
