GMRCADG ;ABV/PIJ - Consults Report by Released by Policy. Patch GMRC*3.0*107 ;7/5/18 07:36
;;3.0;CONSULT/REQUEST TRACKING;**107,119**;DEC 27, 1997;Build 9
;
; LOCAL VISTA REPORT BY GROUPER
;
; Screen Title: Admin Released Consults-Group
;
EN ; -- main entry point for GMRC RPT ADMIN RELEASE CONSULT GROUPER
;
N GMRCEDT1,GMRCEDT2,VALMBCK,VALMCNT,VALMHDR,VALMQUIT
;
D EN^VALM("GMRC RPT ADMIN REL CONS GROUPR")
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,FWD1,FWD2,I,IENS,LINE,ORDITEM,ORIEN,RELBY,X
S (FMRELDT,ORIEN,LINEVAR,X)=""
S LINECNT=0
S FWD1=$O(^GMR(123.1,"B","FORWARDED FROM","")),FWD2=$O(^GMR(123.1,"B","FWD TO REMOTE SERVICE",""))
S:FWD1="" FWD1=999999 S:FWD2="" FWD2=999999
;
K ^TMP("GMRCADG",$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
... ;
... S ORDITEM=$$GET1^DIQ(100.001,IENS,.01) ; Orderable Item
... ;*119*
... S X=""
... I ORDITEM["-ADMIN" S X="ADMIN"
... I ORDITEM["-DS" S X="DS"
... I X="" S X=$$FWD() Q:X="" ;Check if the consult was forwarded from -DS or -ADMIN
... ;
... ; Admin or DS
... I '$D(^TMP("GMRCADG",$J,X)) S ^TMP("GMRCADG",$J,X)=0
... S ^TMP("GMRCADG",$J,X)=^TMP("GMRCADG",$J,X)+1
... ;
... ; Orderable Item
... I '$D(^TMP("GMRCADG",$J,X,ORDITEM)) S ^TMP("GMRCADG",$J,X,ORDITEM)=0
... S ^TMP("GMRCADG",$J,X,ORDITEM)=^TMP("GMRCADG",$J,X,ORDITEM)+1
... ;
... ; Released By
... S RELBY=$$GET1^DIQ(100.008,IENS,17) ; Released by
... I '$D(^TMP("GMRCADG",$J,X,ORDITEM,RELBY)) S ^TMP("GMRCADG",$J,X,ORDITEM,RELBY)=0
... S ^TMP("GMRCADG",$J,X,ORDITEM,RELBY)=^TMP("GMRCADG",$J,X,ORDITEM,RELBY)+1
... ;
Q
;
FWD() ;Check if the consult was forwarded from a consult service -DS or -ADMIN
N ARR,I,IEN123,IEN123S,L,PACKREF,R1,R2,RET
S RET="",PACKREF=$$GET1^DIQ(100,ORIEN_",",33,"E") Q:$P(PACKREF,";",2)'="GMRC" RET
S IEN123=+PACKREF
D GETS^DIQ(123,IEN123_",","40*","IE","ARR")
S L=+$O(ARR(123.02,""),-1)
F I=L:-1:1 S IEN123S=I_","_IEN123_"," Q:'$D(ARR(123.02,IEN123S,1))!(RET]"") D
.S R1=$G(ARR(123.02,IEN123S,1,"I"))=FWD1,R2=$G(ARR(123.02,IEN123S,1,"I"))=FWD2
.I (R1+R2) D Q
..I $G(ARR(123.02,IEN123S,6,"E"))["-DS" S RET="DS"
..I $G(ARR(123.02,IEN123S,6,"E"))["-ADMIN" S RET="ADMIN"
Q RET
;
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
;
; Ask Questions
D EN1
I GMRCQUT S VALMQUIT=1,VALMBCK="Q" Q
;
; ;Build the list for List Manager
D BLDLIST
N ADMINDS,NUM,ORDITEM,RELBY
S (LINE,LINECNT,NUM)=0
;
S (ADMINDS,LINEVAR)=""
;
S ADMINDS=""
F S ADMINDS=$O(^TMP("GMRCADG",$J,ADMINDS)) Q:ADMINDS="" D
. S LINECNT=LINECNT+1
. S LINEVAR=$$SETFLD^VALM1(ADMINDS,LINEVAR,"ADMIN/DS")
. ;
. S NUM=^TMP("GMRCADG",$J,ADMINDS)
. S TOTAL=TOTAL+NUM
. S LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")
. D VALM10(LINEVAR) ; Print first group
. ;
. S ORDITEM=""
. F S ORDITEM=$O(^TMP("GMRCADG",$J,ADMINDS,ORDITEM)) D:ORDITEM="" VALM10("") Q:ORDITEM="" D
.. S LINEVAR=$$SETFLD^VALM1(" "_ORDITEM,LINEVAR,"ADMIN/DS")
.. ;
.. S NUM=^TMP("GMRCADG",$J,ADMINDS,ORDITEM)
.. S LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")
.. ;
.. D VALM10(LINEVAR)
.. ;
.. S RELBY=""
.. F S RELBY=$O(^TMP("GMRCADG",$J,ADMINDS,ORDITEM,RELBY)) D:RELBY="" VALM10("") Q:RELBY="" D
... S LINEVAR=$$SETFLD^VALM1(" "_RELBY,LINEVAR,"ADMIN/DS")
... ;
... S NUM=^TMP("GMRCADG",$J,ADMINDS,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("GMRCADG",$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[HGMRCADG 5113 printed Dec 13, 2024@01:45 Page 2
GMRCADG ;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,119**;DEC 27, 1997;Build 9
+2 ;
+3 ; LOCAL VISTA REPORT BY GROUPER
+4 ;
+5 ; Screen Title: Admin Released Consults-Group
+6 ;
EN ; -- main entry point for GMRC RPT ADMIN RELEASE CONSULT GROUPER
+1 ;
+2 NEW GMRCEDT1,GMRCEDT2,VALMBCK,VALMCNT,VALMHDR,VALMQUIT
+3 ;
+4 DO EN^VALM("GMRC RPT ADMIN REL CONS GROUPR")
+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,FWD1,FWD2,I,IENS,LINE,ORDITEM,ORIEN,RELBY,X
+2 SET (FMRELDT,ORIEN,LINEVAR,X)=""
+3 SET LINECNT=0
+4 SET FWD1=$ORDER(^GMR(123.1,"B","FORWARDED FROM",""))
SET FWD2=$ORDER(^GMR(123.1,"B","FWD TO REMOTE SERVICE",""))
+5 if FWD1=""
SET FWD1=999999
if FWD2=""
SET FWD2=999999
+6 ;
+7 KILL ^TMP("GMRCADG",$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 ; Orderable Item
+12 FOR
SET ORIEN=$ORDER(^OR(100,"AADMINKEY",FMRELDT,"Y",ORIEN))
if ORIEN=""
QUIT
Begin DoDot:3
+13 SET IENS="1,"_ORIEN
+14 ;
+15 ; Orderable Item
SET ORDITEM=$$GET1^DIQ(100.001,IENS,.01)
+16 ;*119*
+17 SET X=""
+18 IF ORDITEM["-ADMIN"
SET X="ADMIN"
+19 IF ORDITEM["-DS"
SET X="DS"
+20 ;Check if the consult was forwarded from -DS or -ADMIN
IF X=""
SET X=$$FWD()
if X=""
QUIT
+21 ;
+22 ; Admin or DS
+23 IF '$DATA(^TMP("GMRCADG",$JOB,X))
SET ^TMP("GMRCADG",$JOB,X)=0
+24 SET ^TMP("GMRCADG",$JOB,X)=^TMP("GMRCADG",$JOB,X)+1
+25 ;
+26 ; Orderable Item
+27 IF '$DATA(^TMP("GMRCADG",$JOB,X,ORDITEM))
SET ^TMP("GMRCADG",$JOB,X,ORDITEM)=0
+28 SET ^TMP("GMRCADG",$JOB,X,ORDITEM)=^TMP("GMRCADG",$JOB,X,ORDITEM)+1
+29 ;
+30 ; Released By
+31 ; Released by
SET RELBY=$$GET1^DIQ(100.008,IENS,17)
+32 IF '$DATA(^TMP("GMRCADG",$JOB,X,ORDITEM,RELBY))
SET ^TMP("GMRCADG",$JOB,X,ORDITEM,RELBY)=0
+33 SET ^TMP("GMRCADG",$JOB,X,ORDITEM,RELBY)=^TMP("GMRCADG",$JOB,X,ORDITEM,RELBY)+1
+34 ;
End DoDot:3
End DoDot:2
End DoDot:1
+35 QUIT
+36 ;
FWD() ;Check if the consult was forwarded from a consult service -DS or -ADMIN
+1 NEW ARR,I,IEN123,IEN123S,L,PACKREF,R1,R2,RET
+2 SET RET=""
SET PACKREF=$$GET1^DIQ(100,ORIEN_",",33,"E")
if $PIECE(PACKREF,";",2)'="GMRC"
QUIT RET
+3 SET IEN123=+PACKREF
+4 DO GETS^DIQ(123,IEN123_",","40*","IE","ARR")
+5 SET L=+$ORDER(ARR(123.02,""),-1)
+6 FOR I=L:-1:1
SET IEN123S=I_","_IEN123_","
if '$DATA(ARR(123.02,IEN123S,1))!(RET]"")
QUIT
Begin DoDot:1
+7 SET R1=$GET(ARR(123.02,IEN123S,1,"I"))=FWD1
SET R2=$GET(ARR(123.02,IEN123S,1,"I"))=FWD2
+8 IF (R1+R2)
Begin DoDot:2
+9 IF $GET(ARR(123.02,IEN123S,6,"E"))["-DS"
SET RET="DS"
+10 IF $GET(ARR(123.02,IEN123S,6,"E"))["-ADMIN"
SET RET="ADMIN"
End DoDot:2
QUIT
End DoDot:1
+11 QUIT RET
+12 ;
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 ; Ask Questions
+9 DO EN1
+10 IF GMRCQUT
SET VALMQUIT=1
SET VALMBCK="Q"
QUIT
+11 ;
+12 ; ;Build the list for List Manager
+13 DO BLDLIST
+14 NEW ADMINDS,NUM,ORDITEM,RELBY
+15 SET (LINE,LINECNT,NUM)=0
+16 ;
+17 SET (ADMINDS,LINEVAR)=""
+18 ;
+19 SET ADMINDS=""
+20 FOR
SET ADMINDS=$ORDER(^TMP("GMRCADG",$JOB,ADMINDS))
if ADMINDS=""
QUIT
Begin DoDot:1
+21 SET LINECNT=LINECNT+1
+22 SET LINEVAR=$$SETFLD^VALM1(ADMINDS,LINEVAR,"ADMIN/DS")
+23 ;
+24 SET NUM=^TMP("GMRCADG",$JOB,ADMINDS)
+25 SET TOTAL=TOTAL+NUM
+26 SET LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")
+27 ; Print first group
DO VALM10(LINEVAR)
+28 ;
+29 SET ORDITEM=""
+30 FOR
SET ORDITEM=$ORDER(^TMP("GMRCADG",$JOB,ADMINDS,ORDITEM))
if ORDITEM=""
DO VALM10("")
if ORDITEM=""
QUIT
Begin DoDot:2
+31 SET LINEVAR=$$SETFLD^VALM1(" "_ORDITEM,LINEVAR,"ADMIN/DS")
+32 ;
+33 SET NUM=^TMP("GMRCADG",$JOB,ADMINDS,ORDITEM)
+34 SET LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")
+35 ;
+36 DO VALM10(LINEVAR)
+37 ;
+38 SET RELBY=""
+39 FOR
SET RELBY=$ORDER(^TMP("GMRCADG",$JOB,ADMINDS,ORDITEM,RELBY))
if RELBY=""
DO VALM10("")
if RELBY=""
QUIT
Begin DoDot:3
+40 SET LINEVAR=$$SETFLD^VALM1(" "_RELBY,LINEVAR,"ADMIN/DS")
+41 ;
+42 SET NUM=^TMP("GMRCADG",$JOB,ADMINDS,ORDITEM,RELBY)
+43 SET LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")
+44 ;
+45 DO VALM10(LINEVAR)
End DoDot:3
End DoDot:2
End DoDot:1
+46 ;
+47 ; Enter blank line
DO VALM10("")
+48 SET LINEVAR="GRAND TOTAL "_TOTAL
+49 DO SET^VALM10(LINE,LINEVAR)
+50 ;
+51 SET VALMBCK="R"
+52 ;
+53 KILL ^TMP("GMRCADG",$JOB)
+54 ;
+55 QUIT
+56 ;
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
