DGPFRDB1 ;SHRPE/SGM - DBRS HISTORY REPORT ; Aug 07, 2018 09:45
;;5.3;Registration;**951**;Aug 13, 1993;Build 135
; Last Edited: SHRPE/SGM, Aug 10, 2018 16:04
;
; ICR# TYPE DESCRIIPTION
;----- ---- ----------------------------
; Sup $$FMTE^XLFDT
; Sup $$STA^XUAF4
;
; Called from DGPFRDB routine
; See DGPFRDB for example format of report
QUIT
;
; PAGE(page#,row#) = line of data in report
; PG = total number of pages in report
;
START ;--- Taskman Entry Point
N X,Y,DGHIST,HEAD,PG,PAGE,RPT,TRM
Q:'$G(DGSRC("ASGN"))
S TRM=($E(IOST)="C")
S PG=0
S RPT=$NA(^TMP("DGPFRDB",$J)) K @RPT
D GET ; create DGHIST()
D BLDHEAD ; create HEAD()
D BLDPAGES ; create formatted pages for the report
D DISPLAY
I TRM W @IOF
K @RPT
Q
;
;------------------------ PRIVATE SUBROUTINES ------------------------
BLDHEAD ; construct HEAD()
;;
;;BEHAVIORAL PRF DISRUPTIVE BEHAVIOR DATA REPORT Page:
;;Patient: [-----patient name-----------] (6890) Dates: 01/01/18 - 03/09/18
;;================================================================================
;; DBRS Number Date DBRS Other Information
;;------------------ -------- --------------------------------------------------
;;
N X,Y,TMP
S X="BEHAVIORAL PRF DISRUPTIVE BEHAVIOR DATA REPORT",$E(X,72)="Page: "
S HEAD(1)=$P($T(BLDHEAD+2),";",3)
;
D GETPAT^DGPFUT2(DGSRC("DFN"),.TMP)
S X="Patient: "_TMP("NAME")_" ("_$E(TMP("SSN"),6,$L(TMP("SSN")))_")"
S Y="Dates: "_$$FMTE(DGSRC("BEG"))_" - "_$$FMTE(DGSRC("END"))
S $E(X,55)=Y
S HEAD(2)=X
S $P(HEAD(3),"=",81)=""
S HEAD(4)=$P($T(BLDHEAD+5),";",3)
S HEAD(5)=$P($T(BLDHEAD+6),";",3)
S HEAD(9)=$TR(HEAD(3),"=","_")
Q
;
BLDPAGES ; construct PAGE(page#,row#)
N J,DATE,ROW
S PG=0
D BLDPGA
I '$G(@RPT@("DATE")) D Q
. S J=" There were no DBRS data edits found for this assignment."
. D BLDPGS(J)
. Q
S DATE="A" F J=0:0 S DATE=$O(@RPT@("DATE",DATE),-1) Q:'DATE D
. N I,L,X,Y,Z,DBRS,DBRSX,OTHER,VAL
. D BLDPGN(0)
. S X=@RPT@("DATE",DATE,0)
. S VAL=$P(X,U),$E(VAL,41)=$P(X,U,2),$E(VAL,51)=$P(X,U,3)
. D BLDPGS(VAL),BLDPGS(HEAD(5))
. S DBRSX=0
. F I=0:0 S DBRSX=$O(@RPT@("DATE",DATE,1,DBRSX)) Q:DBRSX="" D
. . S X=@RPT@("DATE",DATE,1,DBRSX)
. . S DBRS=$P(X,U)
. . S Y=$P(X,U,2)
. . S OTHER=$P(X,U,3)
. . S X=DBRS,$E(X,21)=Y,$E(X,31)=OTHER
. . D BLDPGS(X) S X=$E(X,81,$L(X)) ; remnant no more than 10 chars
. . ; are we at end of page?
. . I (IOSL-ROW)<2 D BLDPGA
. . I $L(X) D BLDPGN(1) S Z="",$E(Z,31)=X D BLDPGS(Z)
. . ; are we at end of page
. . I (IOSL-ROW)<2 D BLDPGA
. . Q
. D BLDPGS("")
. Q
Q
;
BLDPGN(WHERE) ; add a new page?
; if WHERE=0, starting new history record
; if WHERE=1, for a history record writing a DBRS record
I +$G(WHERE)=0 I (IOSL-ROW)>3 Q
I +$G(WHERE) I (IOSL-ROW)>1 Q
;
BLDPGA ; add a new page
; fill out existing page if PG>0
I PG>0,(IOSL-ROW)>0 D
. N L,T,X
. S T=" Press any key to continue, '^' to exit: "
. F L=ROW+1:1:IOSL S X="" S:(L=IOSL)&TRM X=T D BLDPGS(X)
. Q
; start a new page
S PG=1+PG
S @RPT@("RPT",PG,1)=HEAD(1)_PG
N I F I=2:1:5 S @RPT@("RPT",PG,I)=HEAD(I)
S ROW=5
Q
;
BLDPGS(V) ; set a row in PAGE()
S ROW=ROW+1,@RPT@("RPT",PG,ROW)=$E(V,1,80)
Q
;
DISPLAY ;
N I,J,X,PG,OUT,ROW
S OUT=0
I TRM W @IOF
F PG=0:0 S PG=$O(@RPT@("RPT",PG)) Q:'PG D Q:OUT
. N L,X,PAGE
. M PAGE=@RPT@("RPT",PG)
. I PG>1 W @IOF
. F ROW=0:0 S ROW=$O(PAGE(ROW)) Q:'ROW W !,PAGE(ROW)
. I TRM S OUT=$$DISPX
. Q
; for terminal, last page may not have press return text
I TRM D
. S PG=$O(@RPT@("RPT","A"),-1)
. S ROW=$O(@RPT@("RPT",PG,"A"),-1)
. S X=@RPT@("RPT",PG,ROW)
Q
;
DISPX() ; for terminal, check if this is the last page
I '$O(@RPT@("RPT",PG)) D
. I ROW<IOSL W !," Press any key to continue, '^' to exit: "
. Q
N X R X:DTIME
Q $S('$T:1,1:X[U)
;
FMTE(DATE) Q $$FMTE^XLFDT(DATE,"2Z")
;
GET ;
; get the History data
; store a copy of data in ^TMP
; @RPT@("INPUT") = input answers
; @RPT@("HIST",date) = history DGPFAH()
; @RPT@("HIST",9999999) = current DGPFA()
; @RPT@("DATE") = total number of records
; @RPT@("DATE",DATE,0) = SITE_U_EDITDT_U_ENTERBY
; @RPT@("DATE",date,1," "_dbrs#) = dbrs#^ext_date^other
;
N J,X,Y,DATE,DGHIST,DGPFA,ED,ST,TOT
; save input date to ^TMP
M @RPT@("INPUT")=DGSRC
S ST=DGSRC("BEG")-.000001
S ED=(DGSRC("END")+.25)
S TOT=0 ; total# of History records with edited DBRS
;
;--- get all history records sorted by date
D GETALLDT^DGPFAAH(DGSRC("ASGN"),.DGHIST)
F DATE=ST:0 S DATE=$O(DGHIST(DATE)) Q:'DATE Q:DATE>ED D
. N I,X,Y,L,DGPFAH,EDITDT,ENTERBY,IEN,SITE
. S IEN=DGHIST(DATE)
. D GETHIST^DGPFAAH(IEN,.DGPFAH,1)
. Q:'$D(DGPFAH("DBRS"))
. M @RPT@("HIST",DATE)=DGPFAH
. ; assignment history data for the report
. S ENTERBY=$P($G(DGPFAH("ENTERBY")),U,2)
. S EDITDT=$$FMTE(DATE\1)
. S SITE="",Y=$G(DGPFAH("ORIGFAC"))
. I +Y S SITE=$$STA^XUAF4(+Y)_" "_$P(Y,U,2)
. S @RPT@("DATE",DATE,0)=SITE_U_EDITDT_U_ENTERBY
. ;
. S L=0 F S L=$O(DGPFAH("DBRS",L)) Q:'L D
. . N X,Y,DAT,DBDT,DBRS,OTHER,STAT
. . F I=1:1:5 S DAT(I)=$P(DGPFAH("DBRS",L),U,I)
. . S STAT=$P(DAT(4),";")
. . Q:STAT="N" ; no change to DBRS data
. . S DBRS=DAT(1)
. . S OTHER=DAT(2)
. . I STAT="D" S OTHER="[DELETED] "_OTHER
. . I STAT="A" S OTHER="[NEW] "_OTHER
. . S DBDT=$P(DAT(3),";") S:DBDT DBDT=$$FMTE(DBDT\1)
. . S @RPT@("DATE",DATE,1," "_DBRS)=DBRS_U_DBDT_U_OTHER
. . Q
. I $D(@RPT@("DATE",DATE,1)) S TOT=TOT+1
. Q
;
; get the current DBRS data
D GETASGN^DGPFAA(DGSRC("ASGN"),.DGPFA,1) D
. N L,X,SITE
. S X=DGPFA("OWNER")
. S SITE=$$STA^XUAF4(+X)_" "_$P(X,U,2)
. M @RPT@("HIST",9999999)=DGPFA
. S @RPT@("DATE",9999999,0)=SITE_"^Current^"
. F L=0:0 S L=$O(DGPFA("DBRS#",L)) Q:'L D
. . N DATE,DBRS,OTHER
. . S DBRS=$P(DGPFA("DBRS#",L),U)
. . S DATE=$P($G(DGPFA("DBRS DATE",L)),U) S:DATE DATE=$$FMTE(DATE\1)
. . S OTHER=$P($G(DGPFA("DBRS OTHER",L)),U)
. . S @RPT@("DATE",9999999,1," "_DBRS)=DBRS_U_DATE_U_OTHER
. . Q
. S TOT=TOT+1
. Q
S @RPT@("DATE")=TOT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFRDB1 6327 printed Sep 23, 2025@20:24:29 Page 2
DGPFRDB1 ;SHRPE/SGM - DBRS HISTORY REPORT ; Aug 07, 2018 09:45
+1 ;;5.3;Registration;**951**;Aug 13, 1993;Build 135
+2 ; Last Edited: SHRPE/SGM, Aug 10, 2018 16:04
+3 ;
+4 ; ICR# TYPE DESCRIIPTION
+5 ;----- ---- ----------------------------
+6 ; Sup $$FMTE^XLFDT
+7 ; Sup $$STA^XUAF4
+8 ;
+9 ; Called from DGPFRDB routine
+10 ; See DGPFRDB for example format of report
+11 QUIT
+12 ;
+13 ; PAGE(page#,row#) = line of data in report
+14 ; PG = total number of pages in report
+15 ;
START ;--- Taskman Entry Point
+1 NEW X,Y,DGHIST,HEAD,PG,PAGE,RPT,TRM
+2 if '$GET(DGSRC("ASGN"))
QUIT
+3 SET TRM=($EXTRACT(IOST)="C")
+4 SET PG=0
+5 SET RPT=$NAME(^TMP("DGPFRDB",$JOB))
KILL @RPT
+6 ; create DGHIST()
DO GET
+7 ; create HEAD()
DO BLDHEAD
+8 ; create formatted pages for the report
DO BLDPAGES
+9 DO DISPLAY
+10 IF TRM
WRITE @IOF
+11 KILL @RPT
+12 QUIT
+13 ;
+14 ;------------------------ PRIVATE SUBROUTINES ------------------------
BLDHEAD ; construct HEAD()
+1 ;;
+2 ;;BEHAVIORAL PRF DISRUPTIVE BEHAVIOR DATA REPORT Page:
+3 ;;Patient: [-----patient name-----------] (6890) Dates: 01/01/18 - 03/09/18
+4 ;;================================================================================
+5 ;; DBRS Number Date DBRS Other Information
+6 ;;------------------ -------- --------------------------------------------------
+7 ;;
+8 NEW X,Y,TMP
+9 SET X="BEHAVIORAL PRF DISRUPTIVE BEHAVIOR DATA REPORT"
SET $EXTRACT(X,72)="Page: "
+10 SET HEAD(1)=$PIECE($TEXT(BLDHEAD+2),";",3)
+11 ;
+12 DO GETPAT^DGPFUT2(DGSRC("DFN"),.TMP)
+13 SET X="Patient: "_TMP("NAME")_" ("_$EXTRACT(TMP("SSN"),6,$LENGTH(TMP("SSN")))_")"
+14 SET Y="Dates: "_$$FMTE(DGSRC("BEG"))_" - "_$$FMTE(DGSRC("END"))
+15 SET $EXTRACT(X,55)=Y
+16 SET HEAD(2)=X
+17 SET $PIECE(HEAD(3),"=",81)=""
+18 SET HEAD(4)=$PIECE($TEXT(BLDHEAD+5),";",3)
+19 SET HEAD(5)=$PIECE($TEXT(BLDHEAD+6),";",3)
+20 SET HEAD(9)=$TRANSLATE(HEAD(3),"=","_")
+21 QUIT
+22 ;
BLDPAGES ; construct PAGE(page#,row#)
+1 NEW J,DATE,ROW
+2 SET PG=0
+3 DO BLDPGA
+4 IF '$GET(@RPT@("DATE"))
Begin DoDot:1
+5 SET J=" There were no DBRS data edits found for this assignment."
+6 DO BLDPGS(J)
+7 QUIT
End DoDot:1
QUIT
+8 SET DATE="A"
FOR J=0:0
SET DATE=$ORDER(@RPT@("DATE",DATE),-1)
if 'DATE
QUIT
Begin DoDot:1
+9 NEW I,L,X,Y,Z,DBRS,DBRSX,OTHER,VAL
+10 DO BLDPGN(0)
+11 SET X=@RPT@("DATE",DATE,0)
+12 SET VAL=$PIECE(X,U)
SET $EXTRACT(VAL,41)=$PIECE(X,U,2)
SET $EXTRACT(VAL,51)=$PIECE(X,U,3)
+13 DO BLDPGS(VAL)
DO BLDPGS(HEAD(5))
+14 SET DBRSX=0
+15 FOR I=0:0
SET DBRSX=$ORDER(@RPT@("DATE",DATE,1,DBRSX))
if DBRSX=""
QUIT
Begin DoDot:2
+16 SET X=@RPT@("DATE",DATE,1,DBRSX)
+17 SET DBRS=$PIECE(X,U)
+18 SET Y=$PIECE(X,U,2)
+19 SET OTHER=$PIECE(X,U,3)
+20 SET X=DBRS
SET $EXTRACT(X,21)=Y
SET $EXTRACT(X,31)=OTHER
+21 ; remnant no more than 10 chars
DO BLDPGS(X)
SET X=$EXTRACT(X,81,$LENGTH(X))
+22 ; are we at end of page?
+23 IF (IOSL-ROW)<2
DO BLDPGA
+24 IF $LENGTH(X)
DO BLDPGN(1)
SET Z=""
SET $EXTRACT(Z,31)=X
DO BLDPGS(Z)
+25 ; are we at end of page
+26 IF (IOSL-ROW)<2
DO BLDPGA
+27 QUIT
End DoDot:2
+28 DO BLDPGS("")
+29 QUIT
End DoDot:1
+30 QUIT
+31 ;
BLDPGN(WHERE) ; add a new page?
+1 ; if WHERE=0, starting new history record
+2 ; if WHERE=1, for a history record writing a DBRS record
+3 IF +$GET(WHERE)=0
IF (IOSL-ROW)>3
QUIT
+4 IF +$GET(WHERE)
IF (IOSL-ROW)>1
QUIT
+5 ;
BLDPGA ; add a new page
+1 ; fill out existing page if PG>0
+2 IF PG>0
IF (IOSL-ROW)>0
Begin DoDot:1
+3 NEW L,T,X
+4 SET T=" Press any key to continue, '^' to exit: "
+5 FOR L=ROW+1:1:IOSL
SET X=""
if (L=IOSL)&TRM
SET X=T
DO BLDPGS(X)
+6 QUIT
End DoDot:1
+7 ; start a new page
+8 SET PG=1+PG
+9 SET @RPT@("RPT",PG,1)=HEAD(1)_PG
+10 NEW I
FOR I=2:1:5
SET @RPT@("RPT",PG,I)=HEAD(I)
+11 SET ROW=5
+12 QUIT
+13 ;
BLDPGS(V) ; set a row in PAGE()
+1 SET ROW=ROW+1
SET @RPT@("RPT",PG,ROW)=$EXTRACT(V,1,80)
+2 QUIT
+3 ;
DISPLAY ;
+1 NEW I,J,X,PG,OUT,ROW
+2 SET OUT=0
+3 IF TRM
WRITE @IOF
+4 FOR PG=0:0
SET PG=$ORDER(@RPT@("RPT",PG))
if 'PG
QUIT
Begin DoDot:1
+5 NEW L,X,PAGE
+6 MERGE PAGE=@RPT@("RPT",PG)
+7 IF PG>1
WRITE @IOF
+8 FOR ROW=0:0
SET ROW=$ORDER(PAGE(ROW))
if 'ROW
QUIT
WRITE !,PAGE(ROW)
+9 IF TRM
SET OUT=$$DISPX
+10 QUIT
End DoDot:1
if OUT
QUIT
+11 ; for terminal, last page may not have press return text
+12 IF TRM
Begin DoDot:1
+13 SET PG=$ORDER(@RPT@("RPT","A"),-1)
+14 SET ROW=$ORDER(@RPT@("RPT",PG,"A"),-1)
+15 SET X=@RPT@("RPT",PG,ROW)
End DoDot:1
+16 QUIT
+17 ;
DISPX() ; for terminal, check if this is the last page
+1 IF '$ORDER(@RPT@("RPT",PG))
Begin DoDot:1
+2 IF ROW<IOSL
WRITE !," Press any key to continue, '^' to exit: "
+3 QUIT
End DoDot:1
+4 NEW X
READ X:DTIME
+5 QUIT $SELECT('$TEST:1,1:X[U)
+6 ;
FMTE(DATE) QUIT $$FMTE^XLFDT(DATE,"2Z")
+1 ;
GET ;
+1 ; get the History data
+2 ; store a copy of data in ^TMP
+3 ; @RPT@("INPUT") = input answers
+4 ; @RPT@("HIST",date) = history DGPFAH()
+5 ; @RPT@("HIST",9999999) = current DGPFA()
+6 ; @RPT@("DATE") = total number of records
+7 ; @RPT@("DATE",DATE,0) = SITE_U_EDITDT_U_ENTERBY
+8 ; @RPT@("DATE",date,1," "_dbrs#) = dbrs#^ext_date^other
+9 ;
+10 NEW J,X,Y,DATE,DGHIST,DGPFA,ED,ST,TOT
+11 ; save input date to ^TMP
+12 MERGE @RPT@("INPUT")=DGSRC
+13 SET ST=DGSRC("BEG")-.000001
+14 SET ED=(DGSRC("END")+.25)
+15 ; total# of History records with edited DBRS
SET TOT=0
+16 ;
+17 ;--- get all history records sorted by date
+18 DO GETALLDT^DGPFAAH(DGSRC("ASGN"),.DGHIST)
+19 FOR DATE=ST:0
SET DATE=$ORDER(DGHIST(DATE))
if 'DATE
QUIT
if DATE>ED
QUIT
Begin DoDot:1
+20 NEW I,X,Y,L,DGPFAH,EDITDT,ENTERBY,IEN,SITE
+21 SET IEN=DGHIST(DATE)
+22 DO GETHIST^DGPFAAH(IEN,.DGPFAH,1)
+23 if '$DATA(DGPFAH("DBRS"))
QUIT
+24 MERGE @RPT@("HIST",DATE)=DGPFAH
+25 ; assignment history data for the report
+26 SET ENTERBY=$PIECE($GET(DGPFAH("ENTERBY")),U,2)
+27 SET EDITDT=$$FMTE(DATE\1)
+28 SET SITE=""
SET Y=$GET(DGPFAH("ORIGFAC"))
+29 IF +Y
SET SITE=$$STA^XUAF4(+Y)_" "_$PIECE(Y,U,2)
+30 SET @RPT@("DATE",DATE,0)=SITE_U_EDITDT_U_ENTERBY
+31 ;
+32 SET L=0
FOR
SET L=$ORDER(DGPFAH("DBRS",L))
if 'L
QUIT
Begin DoDot:2
+33 NEW X,Y,DAT,DBDT,DBRS,OTHER,STAT
+34 FOR I=1:1:5
SET DAT(I)=$PIECE(DGPFAH("DBRS",L),U,I)
+35 SET STAT=$PIECE(DAT(4),";")
+36 ; no change to DBRS data
if STAT="N"
QUIT
+37 SET DBRS=DAT(1)
+38 SET OTHER=DAT(2)
+39 IF STAT="D"
SET OTHER="[DELETED] "_OTHER
+40 IF STAT="A"
SET OTHER="[NEW] "_OTHER
+41 SET DBDT=$PIECE(DAT(3),";")
if DBDT
SET DBDT=$$FMTE(DBDT\1)
+42 SET @RPT@("DATE",DATE,1," "_DBRS)=DBRS_U_DBDT_U_OTHER
+43 QUIT
End DoDot:2
+44 IF $DATA(@RPT@("DATE",DATE,1))
SET TOT=TOT+1
+45 QUIT
End DoDot:1
+46 ;
+47 ; get the current DBRS data
+48 DO GETASGN^DGPFAA(DGSRC("ASGN"),.DGPFA,1)
Begin DoDot:1
+49 NEW L,X,SITE
+50 SET X=DGPFA("OWNER")
+51 SET SITE=$$STA^XUAF4(+X)_" "_$PIECE(X,U,2)
+52 MERGE @RPT@("HIST",9999999)=DGPFA
+53 SET @RPT@("DATE",9999999,0)=SITE_"^Current^"
+54 FOR L=0:0
SET L=$ORDER(DGPFA("DBRS#",L))
if 'L
QUIT
Begin DoDot:2
+55 NEW DATE,DBRS,OTHER
+56 SET DBRS=$PIECE(DGPFA("DBRS#",L),U)
+57 SET DATE=$PIECE($GET(DGPFA("DBRS DATE",L)),U)
if DATE
SET DATE=$$FMTE(DATE\1)
+58 SET OTHER=$PIECE($GET(DGPFA("DBRS OTHER",L)),U)
+59 SET @RPT@("DATE",9999999,1," "_DBRS)=DBRS_U_DATE_U_OTHER
+60 QUIT
End DoDot:2
+61 SET TOT=TOT+1
+62 QUIT
End DoDot:1
+63 SET @RPT@("DATE")=TOT
+64 QUIT
