DGPFRPI2 ;ALB/RBS - PRF PRINCIPAL INVEST REPORT CONT. ; 6/14/04 10:39am
;;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.
;
;- no direct entry
QUIT
;
PRINT(DGSORT,DGLIST) ;output report
; Input:
; DGSORT - array of user selected report parameters
; DGLIST - temp global name used for report list
; ^TMP("DGPFRPI1",$J)
;
; Output: Formatted report to user selected device
;
N DGBEG ;sort beginning date
N DGDFN ;ien of patient
N DGDT ;date time report printed
N DGFG ;flag name
N DGEND ;sort ending date
N DGHSTR ;header string var
N DGHSTR1 ;header string var
N DGHSTR2 ;header string var
N DGLINE ;string of hyphens (80) for report header format
N DGLN ;loop var
N DGPNAM ;patient name
N DGODFN ;loop var flag
N DGOFG ;name switch flag
N DGOPISTR ;pi name switch flag
N DGPAGE ;page counter
N DGPISTR ;pi name string for sub-header display
N DGQ ;quit flag
N DGSTR ;string of detail line to display
N X,Y
;
S DGHSTR="PATIENT RECORD FLAGS"
S DGHSTR1="ASSIGNMENTS BY PRINCIPAL INVESTIGATOR REPORT"
I DGSORT("DGPRINC")="A" S DGHSTR2="(A)ll Principal Investigators"
E S DGHSTR2="(S)ingle Principal Investigator: "_$P(DGSORT("DGPRINC"),U,2)
S DGDT=$P($$FMTE^XLFDT($$NOW^XLFDT,"T"),":",1,2)
S DGBEG=$$FDATE^VALM1(DGSORT("DGBEG"))
S DGEND=$$FDATE^VALM1(DGSORT("DGEND"))
S (DGQ,DGPAGE)=0,$P(DGLINE,"-",81)=""
;
I $O(@DGLIST@(""))="" D Q
. D HEAD
. W !!," >>> No Record Flag Assignments were found using the report criteria.",!
;
; loop and print report
S (DGDFN,DGFG,DGLN,DGPISTR,DGPNAM,DGODFN,DGOFG,DGOPISTR,DGSTR)=""
;
D HEAD
F S DGFG=$O(@DGLIST@(DGFG)) Q:DGFG="" D Q:DGQ
. S DGPISTR=$$PISTR(DGFG)
. I $Y>(IOSL-10) D PAUSE(.DGQ) Q:DGQ D HEAD,HEAD1,HEAD2,HEAD3 S DGOFG=DGFG,DGOPISTR=DGPISTR
. I DGOFG'=DGFG D
. . W:DGOPISTR]"" !! D HEAD1,HEAD2,HEAD3 S DGOFG=DGFG,DGOPISTR=DGPISTR
. S DGPNAM=0 ;starts looping after "0" princ invest node
. F S DGPNAM=$O(@DGLIST@(DGFG,DGPNAM)) Q:DGPNAM="" D Q:DGQ
. . ; print patient detail line
. . S DGODFN=""
. . F S DGDFN=$O(@DGLIST@(DGFG,DGPNAM,DGDFN)) Q:DGDFN="" D Q:DGQ
. . . S DGLN=""
. . . F S DGLN=$O(@DGLIST@(DGFG,DGPNAM,DGDFN,DGLN)) Q:DGLN="" D Q:DGQ
. . . . I $Y>(IOSL-3) D PAUSE(.DGQ) Q:DGQ D HEAD,HEAD1,HEAD2,HEAD3 S DGODFN=""
. . . . S DGSTR=$G(@DGLIST@(DGFG,DGPNAM,DGDFN,DGLN))
. . . . W !
. . . . I DGODFN'=DGDFN S DGODFN=DGDFN D ;only print name once
. . . . . W $E(DGPNAM,1,16),?18,$P(DGSTR,U)
. . . . W ?30,$P(DGSTR,U,2),?48,$P(DGSTR,U,3),?60,$P(DGSTR,U,4),?71,$P(DGSTR,U,5)
;
;Shutdown if stop task requested
I DGQ W:$D(ZTQUEUED) !!,"REPORT STOPPED AT USER REQUEST" Q
;
W !!,"<End of Report>"
Q
;
PAUSE(DGQ) ; pause screen display
; Input:
; DGQ - var used to quit report processing to user CRT
; Output:
; DGQ - passed by reference - 0 = Continue, 1 = Quit
;
I $G(DGPAGE)>0,$E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQ=1
Q
;
HEAD ;Print/Display page header
;
I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQ)=1 Q
W:'($E(IOST,1,2)'="C-"&'DGPAGE) @IOF
;
S DGPAGE=$G(DGPAGE)+1
W !?(IOM/2)-($L(DGHSTR)/2),DGHSTR
W !?(IOM/2)-($L(DGHSTR1)/2),DGHSTR1
W ?68,"Page: ",$G(DGPAGE)
W !,"Date Range: ",DGBEG_" to "_DGEND
W ?50,"Printed: ",DGDT
W !,"Sorted By: ",DGHSTR2
W !,DGLINE,!
Q
;
HEAD1 W !,"Flag Name: ",$G(DGFG)," - Category II (Local)"
Q
;
HEAD2 W !,"Principal Investigator: "
; <---- length = 24 ----->
; check string length so we don't wrap on screen/printer (80) max
I $L(DGPISTR)'>55 W ?24,DGPISTR
E D
. N X,Y
. S X=""
. F Y=1:1:$L(DGPISTR,"; ") D
. . I $L(X_$P(DGPISTR,"; ",Y))>53 W ?24,X,";" S X="" W !
. . S:X]"" X=X_"; "
. . S X=X_$P(DGPISTR,"; ",Y)
. W ?24,X
Q
;
HEAD3 W !!,"PATIENT",?18,"SSN",?30,"ACTION",?48,"ACTION DT",?60,"REVIEW DT",?71,"STATUS"
W !,"================",?18,"==========",?30,"================",?48,"=========",?60,"=========",?71,"========="
Q
;
PISTR(DGFG) ;string Principal Investigators together for sub-header display
;
; Input:
; DGFG - flag name subscript
;
; Output:
; Function Value - string of Principal Investigator names
; i.e. - "Johnny Cash; Bob Smith; Pete Best; ect..."
;
N DGRSLT ;returned function value
N DGPI ;principal investigator person ien
S DGRSLT=""
;
I $O(@DGLIST@(DGFG,0,""))="" D
. S DGRSLT="No Principal Investigator names on file"
;
I $O(@DGLIST@(DGFG,0,"")) D
. S DGPI=""
. F S DGPI=$O(@DGLIST@(DGFG,0,DGPI)) Q:DGPI="" D Q:$L(DGRSLT)>450
. . S:DGRSLT]"" DGRSLT=DGRSLT_"; "
. . S DGRSLT=DGRSLT_$G(@DGLIST@(DGFG,0,DGPI))
Q DGRSLT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFRPI2 4881 printed Sep 23, 2025@20:24:38 Page 2
DGPFRPI2 ;ALB/RBS - PRF PRINCIPAL INVEST REPORT CONT. ; 6/14/04 10:39am
+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 ;- no direct entry
+7 QUIT
+8 ;
PRINT(DGSORT,DGLIST) ;output report
+1 ; Input:
+2 ; DGSORT - array of user selected report parameters
+3 ; DGLIST - temp global name used for report list
+4 ; ^TMP("DGPFRPI1",$J)
+5 ;
+6 ; Output: Formatted report to user selected device
+7 ;
+8 ;sort beginning date
NEW DGBEG
+9 ;ien of patient
NEW DGDFN
+10 ;date time report printed
NEW DGDT
+11 ;flag name
NEW DGFG
+12 ;sort ending date
NEW DGEND
+13 ;header string var
NEW DGHSTR
+14 ;header string var
NEW DGHSTR1
+15 ;header string var
NEW DGHSTR2
+16 ;string of hyphens (80) for report header format
NEW DGLINE
+17 ;loop var
NEW DGLN
+18 ;patient name
NEW DGPNAM
+19 ;loop var flag
NEW DGODFN
+20 ;name switch flag
NEW DGOFG
+21 ;pi name switch flag
NEW DGOPISTR
+22 ;page counter
NEW DGPAGE
+23 ;pi name string for sub-header display
NEW DGPISTR
+24 ;quit flag
NEW DGQ
+25 ;string of detail line to display
NEW DGSTR
+26 NEW X,Y
+27 ;
+28 SET DGHSTR="PATIENT RECORD FLAGS"
+29 SET DGHSTR1="ASSIGNMENTS BY PRINCIPAL INVESTIGATOR REPORT"
+30 IF DGSORT("DGPRINC")="A"
SET DGHSTR2="(A)ll Principal Investigators"
+31 IF '$TEST
SET DGHSTR2="(S)ingle Principal Investigator: "_$PIECE(DGSORT("DGPRINC"),U,2)
+32 SET DGDT=$PIECE($$FMTE^XLFDT($$NOW^XLFDT,"T"),":",1,2)
+33 SET DGBEG=$$FDATE^VALM1(DGSORT("DGBEG"))
+34 SET DGEND=$$FDATE^VALM1(DGSORT("DGEND"))
+35 SET (DGQ,DGPAGE)=0
SET $PIECE(DGLINE,"-",81)=""
+36 ;
+37 IF $ORDER(@DGLIST@(""))=""
Begin DoDot:1
+38 DO HEAD
+39 WRITE !!," >>> No Record Flag Assignments were found using the report criteria.",!
End DoDot:1
QUIT
+40 ;
+41 ; loop and print report
+42 SET (DGDFN,DGFG,DGLN,DGPISTR,DGPNAM,DGODFN,DGOFG,DGOPISTR,DGSTR)=""
+43 ;
+44 DO HEAD
+45 FOR
SET DGFG=$ORDER(@DGLIST@(DGFG))
if DGFG=""
QUIT
Begin DoDot:1
+46 SET DGPISTR=$$PISTR(DGFG)
+47 IF $Y>(IOSL-10)
DO PAUSE(.DGQ)
if DGQ
QUIT
DO HEAD
DO HEAD1
DO HEAD2
DO HEAD3
SET DGOFG=DGFG
SET DGOPISTR=DGPISTR
+48 IF DGOFG'=DGFG
Begin DoDot:2
+49 if DGOPISTR]""
WRITE !!
DO HEAD1
DO HEAD2
DO HEAD3
SET DGOFG=DGFG
SET DGOPISTR=DGPISTR
End DoDot:2
+50 ;starts looping after "0" princ invest node
SET DGPNAM=0
+51 FOR
SET DGPNAM=$ORDER(@DGLIST@(DGFG,DGPNAM))
if DGPNAM=""
QUIT
Begin DoDot:2
+52 ; print patient detail line
+53 SET DGODFN=""
+54 FOR
SET DGDFN=$ORDER(@DGLIST@(DGFG,DGPNAM,DGDFN))
if DGDFN=""
QUIT
Begin DoDot:3
+55 SET DGLN=""
+56 FOR
SET DGLN=$ORDER(@DGLIST@(DGFG,DGPNAM,DGDFN,DGLN))
if DGLN=""
QUIT
Begin DoDot:4
+57 IF $Y>(IOSL-3)
DO PAUSE(.DGQ)
if DGQ
QUIT
DO HEAD
DO HEAD1
DO HEAD2
DO HEAD3
SET DGODFN=""
+58 SET DGSTR=$GET(@DGLIST@(DGFG,DGPNAM,DGDFN,DGLN))
+59 WRITE !
+60 ;only print name once
IF DGODFN'=DGDFN
SET DGODFN=DGDFN
Begin DoDot:5
+61 WRITE $EXTRACT(DGPNAM,1,16),?18,$PIECE(DGSTR,U)
End DoDot:5
+62 WRITE ?30,$PIECE(DGSTR,U,2),?48,$PIECE(DGSTR,U,3),?60,$PIECE(DGSTR,U,4),?71,$PIECE(DGSTR,U,5)
End DoDot:4
if DGQ
QUIT
End DoDot:3
if DGQ
QUIT
End DoDot:2
if DGQ
QUIT
End DoDot:1
if DGQ
QUIT
+63 ;
+64 ;Shutdown if stop task requested
+65 IF DGQ
if $DATA(ZTQUEUED)
WRITE !!,"REPORT STOPPED AT USER REQUEST"
QUIT
+66 ;
+67 WRITE !!,"<End of Report>"
+68 QUIT
+69 ;
PAUSE(DGQ) ; pause screen display
+1 ; Input:
+2 ; DGQ - var used to quit report processing to user CRT
+3 ; Output:
+4 ; DGQ - passed by reference - 0 = Continue, 1 = Quit
+5 ;
+6 IF $GET(DGPAGE)>0
IF $EXTRACT(IOST,1,2)="C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if +Y=0
SET DGQ=1
+7 QUIT
+8 ;
HEAD ;Print/Display page header
+1 ;
+2 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,DGQ)=1
QUIT
+3 if '($EXTRACT(IOST,1,2)'="C-"&'DGPAGE)
WRITE @IOF
+4 ;
+5 SET DGPAGE=$GET(DGPAGE)+1
+6 WRITE !?(IOM/2)-($LENGTH(DGHSTR)/2),DGHSTR
+7 WRITE !?(IOM/2)-($LENGTH(DGHSTR1)/2),DGHSTR1
+8 WRITE ?68,"Page: ",$GET(DGPAGE)
+9 WRITE !,"Date Range: ",DGBEG_" to "_DGEND
+10 WRITE ?50,"Printed: ",DGDT
+11 WRITE !,"Sorted By: ",DGHSTR2
+12 WRITE !,DGLINE,!
+13 QUIT
+14 ;
HEAD1 WRITE !,"Flag Name: ",$GET(DGFG)," - Category II (Local)"
+1 QUIT
+2 ;
HEAD2 WRITE !,"Principal Investigator: "
+1 ; <---- length = 24 ----->
+2 ; check string length so we don't wrap on screen/printer (80) max
+3 IF $LENGTH(DGPISTR)'>55
WRITE ?24,DGPISTR
+4 IF '$TEST
Begin DoDot:1
+5 NEW X,Y
+6 SET X=""
+7 FOR Y=1:1:$LENGTH(DGPISTR,"; ")
Begin DoDot:2
+8 IF $LENGTH(X_$PIECE(DGPISTR,"; ",Y))>53
WRITE ?24,X,";"
SET X=""
WRITE !
+9 if X]""
SET X=X_"; "
+10 SET X=X_$PIECE(DGPISTR,"; ",Y)
End DoDot:2
+11 WRITE ?24,X
End DoDot:1
+12 QUIT
+13 ;
HEAD3 WRITE !!,"PATIENT",?18,"SSN",?30,"ACTION",?48,"ACTION DT",?60,"REVIEW DT",?71,"STATUS"
+1 WRITE !,"================",?18,"==========",?30,"================",?48,"=========",?60,"=========",?71,"========="
+2 QUIT
+3 ;
PISTR(DGFG) ;string Principal Investigators together for sub-header display
+1 ;
+2 ; Input:
+3 ; DGFG - flag name subscript
+4 ;
+5 ; Output:
+6 ; Function Value - string of Principal Investigator names
+7 ; i.e. - "Johnny Cash; Bob Smith; Pete Best; ect..."
+8 ;
+9 ;returned function value
NEW DGRSLT
+10 ;principal investigator person ien
NEW DGPI
+11 SET DGRSLT=""
+12 ;
+13 IF $ORDER(@DGLIST@(DGFG,0,""))=""
Begin DoDot:1
+14 SET DGRSLT="No Principal Investigator names on file"
End DoDot:1
+15 ;
+16 IF $ORDER(@DGLIST@(DGFG,0,""))
Begin DoDot:1
+17 SET DGPI=""
+18 FOR
SET DGPI=$ORDER(@DGLIST@(DGFG,0,DGPI))
if DGPI=""
QUIT
Begin DoDot:2
+19 if DGRSLT]""
SET DGRSLT=DGRSLT_"; "
+20 SET DGRSLT=DGRSLT_$GET(@DGLIST@(DGFG,0,DGPI))
End DoDot:2
if $LENGTH(DGRSLT)>450
QUIT
End DoDot:1
+21 QUIT DGRSLT
