Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMRCADG

GMRCADG.m

Go to the documentation of this file.
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