DGPFRPI1 ;ALB/RBS - PRF PRINCIPAL INVEST REPORT CONT. ; 6/8/04 5:07pm
;;5.3;Registration;**554**;Aug 13, 1993
;
;This routine will be used to display/print all patient assignments
;for a Principal Investigator assigned to the Research record flag.
;
; Input: DGSORT() - Array containing user report parameters.
;
; Output: A formatted report of the Principal Investigator person's
; associated patient record flag assignments.
;
;- no direct entry
QUIT
;
START ; compile and print report
;
I $E(IOST)="C" D WAIT^DICD
N DGLIST ;temp global name used for report list
S DGLIST=$NA(^TMP("DGPFRPI1",$J))
K @DGLIST
D LOOP(.DGSORT,DGLIST)
D PRINT^DGPFRPI2(.DGSORT,DGLIST)
K @DGLIST
D EXIT
Q
;
LOOP(DGSORT,DGLIST) ;use sort var's for record searching to build list
; Input:
; DGSORT - array of user selected report parameters
; DGLIST - temp global name
;
; Output:
; ^TMP("DGPFRPI1",$J) - temp global containing report output
;
N DGAIEN ;patient assignment ien
N DGBEG ;sort beginning date
N DGCNT ;flag counter
N DGDFNLST ;array of patient dfn's assigned to the flag
N DGEND ;sort ending date
N DGFIEN ;flag ien
N DGFLAG ;local array used to hold flag record
N DGPI ;principal investigator person ien
N DGPIIEN ;sort selection var
N DGPINAME ;name of principal investigator
N DGPINUM ;subscript number for principal investigator
N DGPRINC ;principal investigator sort
N DGSTAT ;status of assignment
N DGSTATUS ;sort status
N DGSUB ;loop flag name var
N DGVPTR ;variable pointer of flag record (i.e.) "25;DGPF(26.11,"
N DGX ;loop var
;
; setup variables equal to user input parameter subscripts
; Only Category II (Local) ^DGPF(26.11) file for Research Flags
; "DGPRINC", "DGSTATUS", "DGBEG", "DGEND"
S DGX="" F S DGX=$O(DGSORT(DGX)) Q:DGX="" S @DGX=DGSORT(DGX)
;
S DGPIIEN=+DGPRINC ; if 0, then 'A'll PI sort was selected
S DGSTAT=+DGSTATUS
S:DGSTAT=2 DGSTAT=0 ; inactive assignment status value is '0'
;
; loop research type (2) record flag x-ref
S DGSUB="",DGCNT=0
F S DGSUB=$O(^DGPF(26.11,"ATYP",2,DGSUB)) Q:DGSUB="" D
. S DGFIEN=""
. F S DGFIEN=$O(^DGPF(26.11,"ATYP",2,DGSUB,DGFIEN)) Q:DGFIEN="" D
. . K DGFLAG
. . Q:'$$GETLF^DGPFALF(DGFIEN,.DGFLAG) ;local flag record data
. . Q:DGPIIEN&'$D(^DGPF(26.11,DGFIEN,2,"B",DGPIIEN))
. . S (DGPINUM,DGPI)=""
. . F S DGPINUM=$O(DGFLAG("PRININV",DGPINUM)) Q:DGPINUM="" D
. . . S DGPI=$P($G(DGFLAG("PRININV",DGPINUM,0)),U)
. . . S DGPINAME=$P($G(DGFLAG("PRININV",DGPINUM,0)),U,2)
. . . S:DGPINAME']"" DGPINAME="Missing Name"
. . . S DGVPTR=DGFIEN_";DGPF(26.11," ; flag variable pointer setup
. . . K DGDFNLST
. . . S DGCNT=$$ASGNCNT^DGPFLF6(DGVPTR,.DGDFNLST) ;patient dfn list
. . . Q:'DGCNT
. . . D BLDTMP(DGBEG,DGEND,DGSTAT,DGPI,DGPINAME,.DGDFNLST,DGLIST)
Q
;
BLDTMP(DGBEG,DGEND,DGSTAT,DGPI,DGPINAME,DGDFNLST,DGLIST) ; list global builder
; Input:
; DGBEG - sort beginning date
; DGEND - sort ending date
; DGSTAT - status of assignment
; DGPI - principal investigator person ien
; DGPINAME - name of principal investigator
; DGDFNLST - array of patient dfn's assigned to the flag
; DGLIST - temp global name used for report list
;
; Output:
; ^TMP("DGPFRPI1",$J) - temp global containing report output
;
N DGACTDT ;initial entry date
N DGAIEN ;patient assignment ien
N DGDFN ;pointer to patient being reported on
N DGFGNM ;flag name
N DGHIEN ;history assignment ien
N DGINIT ;initial assignment date
N DGPFA ;assignment data array
N DGPFAH ;assignment history data array
N DGLINE ;report detail line
N DGPAT ;array of patient demographics
N DGPNM ;patient name
N DGREV ;review date
;
S DGDFN=""
F S DGDFN=$O(DGDFNLST(DGDFN)) Q:DGDFN="" D
. S DGAIEN=$G(DGDFNLST(DGDFN))
. Q:DGAIEN=""
. K DGPFA
. Q:'$$GETASGN^DGPFAA(DGAIEN,.DGPFA) ;get assignment data
. Q:DGDFN'=$P(DGPFA("DFN"),U)
. I DGSTAT'=3,+DGPFA("STATUS")'=DGSTAT Q ;not correct status
. ; get last history record (most current)
. K DGPFAH
. S DGHIEN=$$GETLAST^DGPFAAH(DGAIEN)
. Q:'DGHIEN
. Q:'$$GETHIST^DGPFAAH(DGHIEN,.DGPFAH)
. S DGINIT=+$$GETADT^DGPFAAH(DGAIEN) ;initial assignment date
. Q:'DGINIT
. ; check if assignment falls within the Begin and End dates
. I DGINIT>DGBEG&($P(DGINIT,".")'>DGEND) D
. . ; get patient demographics
. . K DGPAT
. . Q:'$$GETPAT^DGPFUT2(DGDFN,.DGPAT)
. . S DGPNM=DGPAT("NAME")
. . S:DGPNM']"" DGPNM="Missing Patient Name"
. . S DGFGNM=$P(DGPFA("FLAG"),U,2)
. . S:DGFGNM']"" DGFGNM="Missing Flag Name"
. . S DGACTDT=$$FDATE^VALM1(+DGPFAH("ASSIGNDT"))
. . S DGAIEN=+DGPFAH("ASSIGN")
. . I +DGPFA("REVIEWDT") S DGREV=$$FDATE^VALM1(+DGPFA("REVIEWDT"))
. . E S DGREV="N/A"
. . S DGLINE=DGPAT("SSN")_U_$P(DGPFAH("ACTION"),U,2)_U_DGACTDT_U_DGREV_U_$P(DGPFA("STATUS"),U,2)
. . ; - Flag Name, 0 node, IEN of Principal Investigator = PI Name
. . S @DGLIST@(DGFGNM,0,DGPI)=DGPINAME
. . ; - Flag Name, Pat Name, DFN, Asignment IEN
. . S @DGLIST@(DGFGNM,DGPNM,DGDFN,DGAIEN)=DGLINE
Q
;
EXIT ;
I $D(ZTQUEUED) S ZTREQ="@"
I '$D(ZTQUEUED) D
. K %ZIS,POP
. D ^%ZISC,HOME^%ZIS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFRPI1 5338 printed Dec 13, 2024@02:48:45 Page 2
DGPFRPI1 ;ALB/RBS - PRF PRINCIPAL INVEST REPORT CONT. ; 6/8/04 5:07pm
+1 ;;5.3;Registration;**554**;Aug 13, 1993
+2 ;
+3 ;This routine will be used to display/print all patient assignments
+4 ;for a Principal Investigator assigned to the Research record flag.
+5 ;
+6 ; Input: DGSORT() - Array containing user report parameters.
+7 ;
+8 ; Output: A formatted report of the Principal Investigator person's
+9 ; associated patient record flag assignments.
+10 ;
+11 ;- no direct entry
+12 QUIT
+13 ;
START ; compile and print report
+1 ;
+2 IF $EXTRACT(IOST)="C"
DO WAIT^DICD
+3 ;temp global name used for report list
NEW DGLIST
+4 SET DGLIST=$NAME(^TMP("DGPFRPI1",$JOB))
+5 KILL @DGLIST
+6 DO LOOP(.DGSORT,DGLIST)
+7 DO PRINT^DGPFRPI2(.DGSORT,DGLIST)
+8 KILL @DGLIST
+9 DO EXIT
+10 QUIT
+11 ;
LOOP(DGSORT,DGLIST) ;use sort var's for record searching to build list
+1 ; Input:
+2 ; DGSORT - array of user selected report parameters
+3 ; DGLIST - temp global name
+4 ;
+5 ; Output:
+6 ; ^TMP("DGPFRPI1",$J) - temp global containing report output
+7 ;
+8 ;patient assignment ien
NEW DGAIEN
+9 ;sort beginning date
NEW DGBEG
+10 ;flag counter
NEW DGCNT
+11 ;array of patient dfn's assigned to the flag
NEW DGDFNLST
+12 ;sort ending date
NEW DGEND
+13 ;flag ien
NEW DGFIEN
+14 ;local array used to hold flag record
NEW DGFLAG
+15 ;principal investigator person ien
NEW DGPI
+16 ;sort selection var
NEW DGPIIEN
+17 ;name of principal investigator
NEW DGPINAME
+18 ;subscript number for principal investigator
NEW DGPINUM
+19 ;principal investigator sort
NEW DGPRINC
+20 ;status of assignment
NEW DGSTAT
+21 ;sort status
NEW DGSTATUS
+22 ;loop flag name var
NEW DGSUB
+23 ;variable pointer of flag record (i.e.) "25;DGPF(26.11,"
NEW DGVPTR
+24 ;loop var
NEW DGX
+25 ;
+26 ; setup variables equal to user input parameter subscripts
+27 ; Only Category II (Local) ^DGPF(26.11) file for Research Flags
+28 ; "DGPRINC", "DGSTATUS", "DGBEG", "DGEND"
+29 SET DGX=""
FOR
SET DGX=$ORDER(DGSORT(DGX))
if DGX=""
QUIT
SET @DGX=DGSORT(DGX)
+30 ;
+31 ; if 0, then 'A'll PI sort was selected
SET DGPIIEN=+DGPRINC
+32 SET DGSTAT=+DGSTATUS
+33 ; inactive assignment status value is '0'
if DGSTAT=2
SET DGSTAT=0
+34 ;
+35 ; loop research type (2) record flag x-ref
+36 SET DGSUB=""
SET DGCNT=0
+37 FOR
SET DGSUB=$ORDER(^DGPF(26.11,"ATYP",2,DGSUB))
if DGSUB=""
QUIT
Begin DoDot:1
+38 SET DGFIEN=""
+39 FOR
SET DGFIEN=$ORDER(^DGPF(26.11,"ATYP",2,DGSUB,DGFIEN))
if DGFIEN=""
QUIT
Begin DoDot:2
+40 KILL DGFLAG
+41 ;local flag record data
if '$$GETLF^DGPFALF(DGFIEN,.DGFLAG)
QUIT
+42 if DGPIIEN&'$DATA(^DGPF(26.11,DGFIEN,2,"B",DGPIIEN))
QUIT
+43 SET (DGPINUM,DGPI)=""
+44 FOR
SET DGPINUM=$ORDER(DGFLAG("PRININV",DGPINUM))
if DGPINUM=""
QUIT
Begin DoDot:3
+45 SET DGPI=$PIECE($GET(DGFLAG("PRININV",DGPINUM,0)),U)
+46 SET DGPINAME=$PIECE($GET(DGFLAG("PRININV",DGPINUM,0)),U,2)
+47 if DGPINAME']""
SET DGPINAME="Missing Name"
+48 ; flag variable pointer setup
SET DGVPTR=DGFIEN_";DGPF(26.11,"
+49 KILL DGDFNLST
+50 ;patient dfn list
SET DGCNT=$$ASGNCNT^DGPFLF6(DGVPTR,.DGDFNLST)
+51 if 'DGCNT
QUIT
+52 DO BLDTMP(DGBEG,DGEND,DGSTAT,DGPI,DGPINAME,.DGDFNLST,DGLIST)
End DoDot:3
End DoDot:2
End DoDot:1
+53 QUIT
+54 ;
BLDTMP(DGBEG,DGEND,DGSTAT,DGPI,DGPINAME,DGDFNLST,DGLIST) ; list global builder
+1 ; Input:
+2 ; DGBEG - sort beginning date
+3 ; DGEND - sort ending date
+4 ; DGSTAT - status of assignment
+5 ; DGPI - principal investigator person ien
+6 ; DGPINAME - name of principal investigator
+7 ; DGDFNLST - array of patient dfn's assigned to the flag
+8 ; DGLIST - temp global name used for report list
+9 ;
+10 ; Output:
+11 ; ^TMP("DGPFRPI1",$J) - temp global containing report output
+12 ;
+13 ;initial entry date
NEW DGACTDT
+14 ;patient assignment ien
NEW DGAIEN
+15 ;pointer to patient being reported on
NEW DGDFN
+16 ;flag name
NEW DGFGNM
+17 ;history assignment ien
NEW DGHIEN
+18 ;initial assignment date
NEW DGINIT
+19 ;assignment data array
NEW DGPFA
+20 ;assignment history data array
NEW DGPFAH
+21 ;report detail line
NEW DGLINE
+22 ;array of patient demographics
NEW DGPAT
+23 ;patient name
NEW DGPNM
+24 ;review date
NEW DGREV
+25 ;
+26 SET DGDFN=""
+27 FOR
SET DGDFN=$ORDER(DGDFNLST(DGDFN))
if DGDFN=""
QUIT
Begin DoDot:1
+28 SET DGAIEN=$GET(DGDFNLST(DGDFN))
+29 if DGAIEN=""
QUIT
+30 KILL DGPFA
+31 ;get assignment data
if '$$GETASGN^DGPFAA(DGAIEN,.DGPFA)
QUIT
+32 if DGDFN'=$PIECE(DGPFA("DFN"),U)
QUIT
+33 ;not correct status
IF DGSTAT'=3
IF +DGPFA("STATUS")'=DGSTAT
QUIT
+34 ; get last history record (most current)
+35 KILL DGPFAH
+36 SET DGHIEN=$$GETLAST^DGPFAAH(DGAIEN)
+37 if 'DGHIEN
QUIT
+38 if '$$GETHIST^DGPFAAH(DGHIEN,.DGPFAH)
QUIT
+39 ;initial assignment date
SET DGINIT=+$$GETADT^DGPFAAH(DGAIEN)
+40 if 'DGINIT
QUIT
+41 ; check if assignment falls within the Begin and End dates
+42 IF DGINIT>DGBEG&($PIECE(DGINIT,".")'>DGEND)
Begin DoDot:2
+43 ; get patient demographics
+44 KILL DGPAT
+45 if '$$GETPAT^DGPFUT2(DGDFN,.DGPAT)
QUIT
+46 SET DGPNM=DGPAT("NAME")
+47 if DGPNM']""
SET DGPNM="Missing Patient Name"
+48 SET DGFGNM=$PIECE(DGPFA("FLAG"),U,2)
+49 if DGFGNM']""
SET DGFGNM="Missing Flag Name"
+50 SET DGACTDT=$$FDATE^VALM1(+DGPFAH("ASSIGNDT"))
+51 SET DGAIEN=+DGPFAH("ASSIGN")
+52 IF +DGPFA("REVIEWDT")
SET DGREV=$$FDATE^VALM1(+DGPFA("REVIEWDT"))
+53 IF '$TEST
SET DGREV="N/A"
+54 SET DGLINE=DGPAT("SSN")_U_$PIECE(DGPFAH("ACTION"),U,2)_U_DGACTDT_U_DGREV_U_$PIECE(DGPFA("STATUS"),U,2)
+55 ; - Flag Name, 0 node, IEN of Principal Investigator = PI Name
+56 SET @DGLIST@(DGFGNM,0,DGPI)=DGPINAME
+57 ; - Flag Name, Pat Name, DFN, Asignment IEN
+58 SET @DGLIST@(DGFGNM,DGPNM,DGDFN,DGAIEN)=DGLINE
End DoDot:2
End DoDot:1
+59 QUIT
+60 ;
EXIT ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+3 KILL %ZIS,POP
+4 DO ^%ZISC
DO HOME^%ZIS
End DoDot:1
+5 QUIT
