DGPFTR ;SHRPE/YMG - PRF TRANSFER REQUESTS SCREEN ; 05/08/18
;;5.3;Registration;**951**;Aug 13, 1993;Build 135
;;Per VA Directive 6402, this routine should not be modified.
;
; This is the main screen for DGPF PRF TRANSFER REQUESTS option.
;
Q
EN ; entry point
N DSPSTR ; string of filters for display list
;
S DSPSTR="ALL^ALL^ALL^2^ALL" ; default to display all pending requests
; load list template
D EN^VALM("DGPF PRF TRANSFER REQUESTS")
Q
;
HDR ;Header Code
D BLDHDR(DSPSTR)
Q
;
INIT ;Init variables and list array
S VALMBG=1
; display list of pending requests by default
D BLD(DSPSTR)
Q
;
HELP ;Help Code
D FULL^VALM1
W @IOF
W !,"This screen lists PRF transfer requests. It also allows users to review"
W !,"and subsequently approve / reject a pending transfer request."
W !
S VALMBCK="R"
Q
;
EXIT ; exit point
;
D CLEAN^VALM10
D CLEAR^VALM1
Q
;
BLD(STR) ; build list of transfer requests for display
; STR - string of parameters that limit which entries to include:
; query id ^ patient ^ PRF flag ^ request status ^ start date/time ^ end date/time
; Note: any piece may be set to "ALL" instead of an actual value
;
N EDTM,FLAG,PAT,REQIEN,SDTM,STATUS
N DIDX,DIDX1,DIDX2,FIDX,FIDX1,FIDX2,PIDX,PIDX1,PIDX2,SIDX,SIDX1,SIDX2
D CLEAN^VALM10 S VALMCNT=0
W !!,"Working..."
I $P(STR,U)'="ALL" D Q
.; looking for a specific query id - there's only one entry possible
.S REQIEN=$$FNDLOG^DGPFHLT3($P(STR,U))
.I 'REQIEN S VALMCNT=$$NOREC() Q
.S VALMCNT=$$BLDLN(VALMCNT,REQIEN)
.Q
S PAT=$P(STR,U,2),FLAG=$P(STR,U,3),STATUS=$P(STR,U,4),SDTM=$P(STR,U,5),EDTM=$P(STR,U,6)
; loop through patient level
S PIDX1=$S(PAT="ALL":"",1:$O(^DGPF(26.22,"D",PAT),-1))
S PIDX2=$S(PAT="ALL":"",1:$O(^DGPF(26.22,"D",PAT)))
S PIDX=PIDX1 F S PIDX=$O(^DGPF(26.22,"D",PIDX)) Q:PIDX=PIDX2 D
.; loop through flag level
.S FIDX1=$S(FLAG="ALL":"",1:$O(^DGPF(26.22,"D",PIDX,FLAG),-1))
.S FIDX2=$S(FLAG="ALL":"",1:$O(^DGPF(26.22,"D",PIDX,FLAG)))
.S FIDX=FIDX1 F S FIDX=$O(^DGPF(26.22,"D",PIDX,FIDX)) Q:FIDX=FIDX2 D
..; loop through status level
..S SIDX1=$S(STATUS="ALL":"",1:$O(^DGPF(26.22,"D",PIDX,FIDX,STATUS),-1))
..S SIDX2=$S(STATUS="ALL":"",1:$O(^DGPF(26.22,"D",PIDX,FIDX,STATUS)))
..S SIDX=SIDX1 F S SIDX=$O(^DGPF(26.22,"D",PIDX,FIDX,SIDX)) Q:SIDX=SIDX2 D
...; loop through request date/time level
...S DIDX1=$S(SDTM="ALL":"",1:$O(^DGPF(26.22,"D",PIDX,FIDX,SIDX,SDTM),-1))
...S DIDX2=$S(SDTM="ALL":"",EDTM="ALL":"",1:$O(^DGPF(26.22,"D",PIDX,FIDX,SIDX,EDTM)))
...S DIDX=DIDX1 F S DIDX=$O(^DGPF(26.22,"D",PIDX,FIDX,SIDX,DIDX)) Q:DIDX=DIDX2 D
....S REQIEN=$O(^DGPF(26.22,"D",PIDX,FIDX,SIDX,DIDX,""))
....I REQIEN S VALMCNT=$$BLDLN(VALMCNT,REQIEN)
....I '(VALMCNT#10) W "."
....Q
...Q
..Q
.Q
I VALMCNT=0 S VALMCNT=$$NOREC()
Q
;
NOREC() ; show message when display list is empty
; returns line count in the created array
;
D SET^VALM10(1,"")
D SET^VALM10(2,"")
D SET^VALM10(3,$$SETSTR^VALM1("No transfer request(s) found.","",26,29))
Q 3
;
BLDLN(LNUM,REQIEN) ; build one line to display
; LNUM - last line number
; REQIEN - request ien in file 26.22
;
; returns current line number
;
N DGFDA,FLAG,IENS,LINE,LN,PAT,REQDTM,STATUS
; get data from 26.22
S IENS=REQIEN_"," D GETS^DIQ(26.22,IENS,".01;.03:.05","EI","DGFDA")
S PAT=$G(DGFDA(26.22,IENS,.03,"E"))
S FLAG=$G(DGFDA(26.22,IENS,.04,"E"))
S STATUS=$G(DGFDA(26.22,IENS,.05,"E"))
S REQDTM=$$FMTE^XLFDT($G(DGFDA(26.22,IENS,.01,"I")),"2DZ")
; build line
S LINE="",LN=LNUM+1
S LINE=$$SETSTR^VALM1(LN,LINE,1,3)
S LINE=$$SETFLD^VALM1(PAT,LINE,"PATIENT")
S LINE=$$SETFLD^VALM1(FLAG,LINE,"FLAG")
S LINE=$$SETFLD^VALM1(STATUS,LINE,"STATUS")
S LINE=$$SETFLD^VALM1(REQDTM,LINE,"DATE")
D SET^VALM10(LN,LINE,LN)
S @VALMAR@("IDX",LN,LN)=$G(REQIEN)
Q LN
;
BLDHDR(STR) ; build display header
; STR - string of parameters for the current view (see tag BLD)
;
N EDTM,FLAG,PAT,QID,SDTM,STATUS
S QID=$P(STR,U),PAT=$P(STR,U,2),FLAG=$P(STR,U,3),STATUS=$P(STR,U,4),SDTM=$P(STR,U,5),EDTM=$P(STR,U,6)
S VALMHDR(1)="Current view:"
S VALMHDR(2)="Query Id: "_$$LJ^XLFSTR(QID,4) I QID'="ALL" Q
S VALMHDR(2)=VALMHDR(2)_"Req. Status: "_$$LJ^XLFSTR($S(STATUS="ALL":STATUS,1:$$EXTERNAL^DILFD(26.22,.05,,STATUS)),8)
S VALMHDR(2)=VALMHDR(2)_" Dates: "_$$FMTE^XLFDT(SDTM,"2Z")_$S(SDTM="ALL":"",+$P(SDTM,".",2)'>0:"@00:00:00",1:"")
I EDTM'="" S VALMHDR(2)=VALMHDR(2)_" - "_$$FMTE^XLFDT(EDTM,"2Z")_$S(+$P(EDTM,".",2)'>0:"@00:00:00",1:"")
S VALMHDR(3)="Patient: "_$$LJ^XLFSTR($S(PAT="ALL":PAT,1:$$EXTERNAL^DILFD(26.22,.03,,$P(STR,U,2))),39)
S VALMHDR(3)=VALMHDR(3)_"Flag: "_$$LJ^XLFSTR($S(FLAG="ALL":FLAG,1:$$EXTERNAL^DILFD(26.22,.04,,$P(STR,U,3))),39)
S VALMHDR(4)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFTR 4809 printed Oct 16, 2024@18:49:24 Page 2
DGPFTR ;SHRPE/YMG - PRF TRANSFER REQUESTS SCREEN ; 05/08/18
+1 ;;5.3;Registration;**951**;Aug 13, 1993;Build 135
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This is the main screen for DGPF PRF TRANSFER REQUESTS option.
+5 ;
+6 QUIT
EN ; entry point
+1 ; string of filters for display list
NEW DSPSTR
+2 ;
+3 ; default to display all pending requests
SET DSPSTR="ALL^ALL^ALL^2^ALL"
+4 ; load list template
+5 DO EN^VALM("DGPF PRF TRANSFER REQUESTS")
+6 QUIT
+7 ;
HDR ;Header Code
+1 DO BLDHDR(DSPSTR)
+2 QUIT
+3 ;
INIT ;Init variables and list array
+1 SET VALMBG=1
+2 ; display list of pending requests by default
+3 DO BLD(DSPSTR)
+4 QUIT
+5 ;
HELP ;Help Code
+1 DO FULL^VALM1
+2 WRITE @IOF
+3 WRITE !,"This screen lists PRF transfer requests. It also allows users to review"
+4 WRITE !,"and subsequently approve / reject a pending transfer request."
+5 WRITE !
+6 SET VALMBCK="R"
+7 QUIT
+8 ;
EXIT ; exit point
+1 ;
+2 DO CLEAN^VALM10
+3 DO CLEAR^VALM1
+4 QUIT
+5 ;
BLD(STR) ; build list of transfer requests for display
+1 ; STR - string of parameters that limit which entries to include:
+2 ; query id ^ patient ^ PRF flag ^ request status ^ start date/time ^ end date/time
+3 ; Note: any piece may be set to "ALL" instead of an actual value
+4 ;
+5 NEW EDTM,FLAG,PAT,REQIEN,SDTM,STATUS
+6 NEW DIDX,DIDX1,DIDX2,FIDX,FIDX1,FIDX2,PIDX,PIDX1,PIDX2,SIDX,SIDX1,SIDX2
+7 DO CLEAN^VALM10
SET VALMCNT=0
+8 WRITE !!,"Working..."
+9 IF $PIECE(STR,U)'="ALL"
Begin DoDot:1
+10 ; looking for a specific query id - there's only one entry possible
+11 SET REQIEN=$$FNDLOG^DGPFHLT3($PIECE(STR,U))
+12 IF 'REQIEN
SET VALMCNT=$$NOREC()
QUIT
+13 SET VALMCNT=$$BLDLN(VALMCNT,REQIEN)
+14 QUIT
End DoDot:1
QUIT
+15 SET PAT=$PIECE(STR,U,2)
SET FLAG=$PIECE(STR,U,3)
SET STATUS=$PIECE(STR,U,4)
SET SDTM=$PIECE(STR,U,5)
SET EDTM=$PIECE(STR,U,6)
+16 ; loop through patient level
+17 SET PIDX1=$SELECT(PAT="ALL":"",1:$ORDER(^DGPF(26.22,"D",PAT),-1))
+18 SET PIDX2=$SELECT(PAT="ALL":"",1:$ORDER(^DGPF(26.22,"D",PAT)))
+19 SET PIDX=PIDX1
FOR
SET PIDX=$ORDER(^DGPF(26.22,"D",PIDX))
if PIDX=PIDX2
QUIT
Begin DoDot:1
+20 ; loop through flag level
+21 SET FIDX1=$SELECT(FLAG="ALL":"",1:$ORDER(^DGPF(26.22,"D",PIDX,FLAG),-1))
+22 SET FIDX2=$SELECT(FLAG="ALL":"",1:$ORDER(^DGPF(26.22,"D",PIDX,FLAG)))
+23 SET FIDX=FIDX1
FOR
SET FIDX=$ORDER(^DGPF(26.22,"D",PIDX,FIDX))
if FIDX=FIDX2
QUIT
Begin DoDot:2
+24 ; loop through status level
+25 SET SIDX1=$SELECT(STATUS="ALL":"",1:$ORDER(^DGPF(26.22,"D",PIDX,FIDX,STATUS),-1))
+26 SET SIDX2=$SELECT(STATUS="ALL":"",1:$ORDER(^DGPF(26.22,"D",PIDX,FIDX,STATUS)))
+27 SET SIDX=SIDX1
FOR
SET SIDX=$ORDER(^DGPF(26.22,"D",PIDX,FIDX,SIDX))
if SIDX=SIDX2
QUIT
Begin DoDot:3
+28 ; loop through request date/time level
+29 SET DIDX1=$SELECT(SDTM="ALL":"",1:$ORDER(^DGPF(26.22,"D",PIDX,FIDX,SIDX,SDTM),-1))
+30 SET DIDX2=$SELECT(SDTM="ALL":"",EDTM="ALL":"",1:$ORDER(^DGPF(26.22,"D",PIDX,FIDX,SIDX,EDTM)))
+31 SET DIDX=DIDX1
FOR
SET DIDX=$ORDER(^DGPF(26.22,"D",PIDX,FIDX,SIDX,DIDX))
if DIDX=DIDX2
QUIT
Begin DoDot:4
+32 SET REQIEN=$ORDER(^DGPF(26.22,"D",PIDX,FIDX,SIDX,DIDX,""))
+33 IF REQIEN
SET VALMCNT=$$BLDLN(VALMCNT,REQIEN)
+34 IF '(VALMCNT#10)
WRITE "."
+35 QUIT
End DoDot:4
+36 QUIT
End DoDot:3
+37 QUIT
End DoDot:2
+38 QUIT
End DoDot:1
+39 IF VALMCNT=0
SET VALMCNT=$$NOREC()
+40 QUIT
+41 ;
NOREC() ; show message when display list is empty
+1 ; returns line count in the created array
+2 ;
+3 DO SET^VALM10(1,"")
+4 DO SET^VALM10(2,"")
+5 DO SET^VALM10(3,$$SETSTR^VALM1("No transfer request(s) found.","",26,29))
+6 QUIT 3
+7 ;
BLDLN(LNUM,REQIEN) ; build one line to display
+1 ; LNUM - last line number
+2 ; REQIEN - request ien in file 26.22
+3 ;
+4 ; returns current line number
+5 ;
+6 NEW DGFDA,FLAG,IENS,LINE,LN,PAT,REQDTM,STATUS
+7 ; get data from 26.22
+8 SET IENS=REQIEN_","
DO GETS^DIQ(26.22,IENS,".01;.03:.05","EI","DGFDA")
+9 SET PAT=$GET(DGFDA(26.22,IENS,.03,"E"))
+10 SET FLAG=$GET(DGFDA(26.22,IENS,.04,"E"))
+11 SET STATUS=$GET(DGFDA(26.22,IENS,.05,"E"))
+12 SET REQDTM=$$FMTE^XLFDT($GET(DGFDA(26.22,IENS,.01,"I")),"2DZ")
+13 ; build line
+14 SET LINE=""
SET LN=LNUM+1
+15 SET LINE=$$SETSTR^VALM1(LN,LINE,1,3)
+16 SET LINE=$$SETFLD^VALM1(PAT,LINE,"PATIENT")
+17 SET LINE=$$SETFLD^VALM1(FLAG,LINE,"FLAG")
+18 SET LINE=$$SETFLD^VALM1(STATUS,LINE,"STATUS")
+19 SET LINE=$$SETFLD^VALM1(REQDTM,LINE,"DATE")
+20 DO SET^VALM10(LN,LINE,LN)
+21 SET @VALMAR@("IDX",LN,LN)=$GET(REQIEN)
+22 QUIT LN
+23 ;
BLDHDR(STR) ; build display header
+1 ; STR - string of parameters for the current view (see tag BLD)
+2 ;
+3 NEW EDTM,FLAG,PAT,QID,SDTM,STATUS
+4 SET QID=$PIECE(STR,U)
SET PAT=$PIECE(STR,U,2)
SET FLAG=$PIECE(STR,U,3)
SET STATUS=$PIECE(STR,U,4)
SET SDTM=$PIECE(STR,U,5)
SET EDTM=$PIECE(STR,U,6)
+5 SET VALMHDR(1)="Current view:"
+6 SET VALMHDR(2)="Query Id: "_$$LJ^XLFSTR(QID,4)
IF QID'="ALL"
QUIT
+7 SET VALMHDR(2)=VALMHDR(2)_"Req. Status: "_$$LJ^XLFSTR($SELECT(STATUS="ALL":STATUS,1:$$EXTERNAL^DILFD(26.22,.05,,STATUS)),8)
+8 SET VALMHDR(2)=VALMHDR(2)_" Dates: "_$$FMTE^XLFDT(SDTM,"2Z")_$SELECT(SDTM="ALL":"",+$PIECE(SDTM,".",2)'>0:"@00:00:00",1:"")
+9 IF EDTM'=""
SET VALMHDR(2)=VALMHDR(2)_" - "_$$FMTE^XLFDT(EDTM,"2Z")_$SELECT(+$PIECE(EDTM,".",2)'>0:"@00:00:00",1:"")
+10 SET VALMHDR(3)="Patient: "_$$LJ^XLFSTR($SELECT(PAT="ALL":PAT,1:$$EXTERNAL^DILFD(26.22,.03,,$PIECE(STR,U,2))),39)
+11 SET VALMHDR(3)=VALMHDR(3)_"Flag: "_$$LJ^XLFSTR($SELECT(FLAG="ALL":FLAG,1:$$EXTERNAL^DILFD(26.22,.04,,$PIECE(STR,U,3))),39)
+12 SET VALMHDR(4)=""
+13 QUIT
