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.
  1. 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
  1. ;
  1. ; LOCAL VISTA REPORT BY GROUPER
  1. ;
  1. ; Screen Title: Admin Released Consults-Group
  1. ;
  1. EN ; -- main entry point for GMRC RPT ADMIN RELEASE CONSULT GROUPER
  1. ;
  1. N GMRCEDT1,GMRCEDT2,VALMBCK,VALMCNT,VALMHDR,VALMQUIT
  1. ;
  1. D EN^VALM("GMRC RPT ADMIN REL CONS GROUPR")
  1. Q
  1. ;
  1. EN1 ;Ask for date range
  1. ;
  1. S DIR(0)="DA",DIR("A")="Enter Consult Released Starting Date: "
  1. D ^DIR
  1. I $D(DUOUT)!($D(DTOUT)) S GMRCQUT=1 Q
  1. S GMRCDT1=+Y I 'GMRCDT1 G EN1
  1. W " (",$$FMTE^XLFDT(GMRCDT1)_")"
  1. ;
  1. K DIR
  1. S DIR(0)="DA",DIR("A")="Enter Consult Released Ending Date: "
  1. D ^DIR
  1. I $D(DTOUT)!($D(DUOUT)) K GMRCDT1 S GMRCQUT=1 G EXIT
  1. I +Y<GMRCDT1 W !!,$C(7),"Ending Date Can Not Be Before Starting Date.",! G EN1
  1. I $G(GMRCDT2)="" S GMRCDT2=+Y
  1. W " (",$$FMTE^XLFDT(GMRCDT2)_")"
  1. ;
  1. ; Retrieve External Date
  1. D LISTDATE^GMRCSTU1(GMRCDT1,GMRCDT2,.GMRCEDT1,.GMRCEDT2)
  1. ;
  1. Q
  1. ;
  1. HDR ; -- header code
  1. N GMRCSITE
  1. S GMRCSITE=$P($$SITE^VASITE(),U,2)
  1. S VALMHDR(1)="VAMC: "_GMRCSITE
  1. S VALMHDR(2)="From: "_$G(GMRCEDT1)_" To: "_$G(GMRCEDT2)
  1. Q
  1. ;
  1. BLDLIST ; -- init variables and list array
  1. N FMRELDT,FWD1,FWD2,I,IENS,LINE,ORDITEM,ORIEN,RELBY,X
  1. S (FMRELDT,ORIEN,LINEVAR,X)=""
  1. S LINECNT=0
  1. S FWD1=$O(^GMR(123.1,"B","FORWARDED FROM","")),FWD2=$O(^GMR(123.1,"B","FWD TO REMOTE SERVICE",""))
  1. S:FWD1="" FWD1=999999 S:FWD2="" FWD2=999999
  1. ;
  1. K ^TMP("GMRCADG",$J)
  1. ;
  1. F S FMRELDT=$O(^OR(100,"AADMINKEY",FMRELDT)) Q:FMRELDT="" D
  1. . F I=GMRCDT1:1:GMRCDT2 I $P(I,".",1)=$P(FMRELDT,".",1) D
  1. .. ; Orderable Item
  1. .. F S ORIEN=$O(^OR(100,"AADMINKEY",FMRELDT,"Y",ORIEN)) Q:ORIEN="" D
  1. ... S IENS="1,"_ORIEN
  1. ... ;
  1. ... S ORDITEM=$$GET1^DIQ(100.001,IENS,.01) ; Orderable Item
  1. ... ;*119*
  1. ... S X=""
  1. ... I ORDITEM["-ADMIN" S X="ADMIN"
  1. ... I ORDITEM["-DS" S X="DS"
  1. ... I X="" S X=$$FWD() Q:X="" ;Check if the consult was forwarded from -DS or -ADMIN
  1. ... ;
  1. ... ; Admin or DS
  1. ... I '$D(^TMP("GMRCADG",$J,X)) S ^TMP("GMRCADG",$J,X)=0
  1. ... S ^TMP("GMRCADG",$J,X)=^TMP("GMRCADG",$J,X)+1
  1. ... ;
  1. ... ; Orderable Item
  1. ... I '$D(^TMP("GMRCADG",$J,X,ORDITEM)) S ^TMP("GMRCADG",$J,X,ORDITEM)=0
  1. ... S ^TMP("GMRCADG",$J,X,ORDITEM)=^TMP("GMRCADG",$J,X,ORDITEM)+1
  1. ... ;
  1. ... ; Released By
  1. ... S RELBY=$$GET1^DIQ(100.008,IENS,17) ; Released by
  1. ... I '$D(^TMP("GMRCADG",$J,X,ORDITEM,RELBY)) S ^TMP("GMRCADG",$J,X,ORDITEM,RELBY)=0
  1. ... S ^TMP("GMRCADG",$J,X,ORDITEM,RELBY)=^TMP("GMRCADG",$J,X,ORDITEM,RELBY)+1
  1. ... ;
  1. Q
  1. ;
  1. FWD() ;Check if the consult was forwarded from a consult service -DS or -ADMIN
  1. N ARR,I,IEN123,IEN123S,L,PACKREF,R1,R2,RET
  1. S RET="",PACKREF=$$GET1^DIQ(100,ORIEN_",",33,"E") Q:$P(PACKREF,";",2)'="GMRC" RET
  1. S IEN123=+PACKREF
  1. D GETS^DIQ(123,IEN123_",","40*","IE","ARR")
  1. S L=+$O(ARR(123.02,""),-1)
  1. F I=L:-1:1 S IEN123S=I_","_IEN123_"," Q:'$D(ARR(123.02,IEN123S,1))!(RET]"") D
  1. .S R1=$G(ARR(123.02,IEN123S,1,"I"))=FWD1,R2=$G(ARR(123.02,IEN123S,1,"I"))=FWD2
  1. .I (R1+R2) D Q
  1. ..I $G(ARR(123.02,IEN123S,6,"E"))["-DS" S RET="DS"
  1. ..I $G(ARR(123.02,IEN123S,6,"E"))["-ADMIN" S RET="ADMIN"
  1. Q RET
  1. ;
  1. INIT ;
  1. K ^TMP("VALMAR",$J)
  1. N DTOUT,DIR,DUOUT,DIRUT,GMRCQUT,X,Y,TOTAL
  1. N GMRCDT1,GMRCDT2,LINECNT
  1. ;
  1. S (GMRCDT1,GMRCDT2,GMRCEDT1,GMRCEDT2,GMRCQUT)=""
  1. S (LINECNT,TOTAL,VALMCNT)=0
  1. ;
  1. ; Ask Questions
  1. D EN1
  1. I GMRCQUT S VALMQUIT=1,VALMBCK="Q" Q
  1. ;
  1. ; ;Build the list for List Manager
  1. D BLDLIST
  1. N ADMINDS,NUM,ORDITEM,RELBY
  1. S (LINE,LINECNT,NUM)=0
  1. ;
  1. S (ADMINDS,LINEVAR)=""
  1. ;
  1. S ADMINDS=""
  1. F S ADMINDS=$O(^TMP("GMRCADG",$J,ADMINDS)) Q:ADMINDS="" D
  1. . S LINECNT=LINECNT+1
  1. . S LINEVAR=$$SETFLD^VALM1(ADMINDS,LINEVAR,"ADMIN/DS")
  1. . ;
  1. . S NUM=^TMP("GMRCADG",$J,ADMINDS)
  1. . S TOTAL=TOTAL+NUM
  1. . S LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")
  1. . D VALM10(LINEVAR) ; Print first group
  1. . ;
  1. . S ORDITEM=""
  1. . F S ORDITEM=$O(^TMP("GMRCADG",$J,ADMINDS,ORDITEM)) D:ORDITEM="" VALM10("") Q:ORDITEM="" D
  1. .. S LINEVAR=$$SETFLD^VALM1(" "_ORDITEM,LINEVAR,"ADMIN/DS")
  1. .. ;
  1. .. S NUM=^TMP("GMRCADG",$J,ADMINDS,ORDITEM)
  1. .. S LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")
  1. .. ;
  1. .. D VALM10(LINEVAR)
  1. .. ;
  1. .. S RELBY=""
  1. .. F S RELBY=$O(^TMP("GMRCADG",$J,ADMINDS,ORDITEM,RELBY)) D:RELBY="" VALM10("") Q:RELBY="" D
  1. ... S LINEVAR=$$SETFLD^VALM1(" "_RELBY,LINEVAR,"ADMIN/DS")
  1. ... ;
  1. ... S NUM=^TMP("GMRCADG",$J,ADMINDS,ORDITEM,RELBY)
  1. ... S LINEVAR=$$SETFLD^VALM1(NUM,LINEVAR,"NUM")
  1. ... ;
  1. ... D VALM10(LINEVAR)
  1. ;
  1. D VALM10("") ; Enter blank line
  1. S LINEVAR="GRAND TOTAL "_TOTAL
  1. D SET^VALM10(LINE,LINEVAR)
  1. ;
  1. S VALMBCK="R"
  1. ;
  1. K ^TMP("GMRCADG",$J)
  1. ;
  1. Q
  1. ;
  1. VALM10(LINEVAR) ;
  1. S LINE=LINE+1
  1. D SET^VALM10(LINE,LINEVAR)
  1. S VALMCNT=LINE
  1. Q
  1. ;
  1. HELP ; -- help code
  1. S X="?" D DISP^XQORM1 W !!
  1. Q
  1. ;
  1. EXIT ; -- exit code
  1. K ^TMP("VALMAR",$J)
  1. Q
  1. ;
  1. EXPND ; -- expand code
  1. Q
  1. ;
  1. DTRES ;Restore old date in case user '^' out.
  1. I $D(GMRCDTS1) S GMRCDT1=GMRCDTS1
  1. I $D(GMRCDTS2) S GMRCDT2=GMRCDTS2
  1. K GMRCDTS1,GMRCDTS2
  1. Q