- 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 Feb 18, 2025@23:11:23 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