DGPFRFA1 ;ALB/RBS - PRF FLAG ASSIGNMENT REPORT CONT. ; 1/21/04 5:14pm
;;5.3;Registration;**425,554,960**;Aug 13, 1993;Build 22
; Last Edited: SHRPE/sgm - Jul 9, 2018 13:30
;
; ICR# TYPE DESCRIPTION
;----- ---- ---------------------------------
;10024 Sup WAIT^DICD
;10026 Sup ^DIR
;10086 Sup HOME^%ZIS
;10103 Sup ^XLFDT: $$FMDIFF, $$FMTE, $$NOW
;10063 Sup $$S^%ZTLOAD
;
;This routine will compile and produce the FLAG ASSIGNMENT REPORT.
;This routine will be used to display or print all of the patient
; assignments for Category I and Category II Patient Record Flags.
;
;All sort input was created in routine DGPFRFA passed by Taskman
; Input: The following array contains the sort var's:
;
; DGSORT(subscript)=value [see routine DGPFRFA for details]
;
; Output: A formatted report of Record Flag Assignments to patients.
;5/1/2018 - DG*5.3*960 - report format substantially changed
;- no direct entry
QUIT
;
START ; compile and print report
N DGLIST,HDR,LINE,TRM,ZTSTOP
N DGC,DGF,DGO,DGS,DGBEG,DGEND
S ZTSTOP=0
K ^TMP("DGPFRFA1",$J)
S DGLIST=$NA(^TMP("DGPFRFA1",$J))
S $P(LINE,"-",104)=""
;
D ; convert some DGSORT() to convenient local variables
. ; DGC, DGF, DGO, DGS
. ; Category, Flag, Ownership, Status
. N X
. S (DGBEG,DGC,DGEND,DGF,DGO,DGS)=""
. ; convert category to 0 or file# of variable pointer
. S X=+DGSORT("DGCAT") S DGC=$S(X=3:0,X=1:26.15,1:26.11)
. ;
. ; convert ownership to 1:Local; 2:Other; 0:Both
. S X=+DGSORT("DGOWN") S DGO=$S(X=3:0,1:X)
. ;
. ; status 0:Inactive 1:Active
. ; reset so coordinated with ^DD(26.13)
. S DGS=(+DGSORT("DGSTAT")=1)
. ;
. ; DGF = A:all or variable pointer syntax for single flag
. S DGF=$P(DGSORT("DGFLAG"),U)
. S DGBEG=(DGSORT("DGBEG")\1)
. S DGEND=(DGSORT("DGEND")\1)
. Q
;
S TRM=($E(IOST)="C") I TRM D WAIT^DICD
; START module initialized 6 local variables used by next code
D A1 ; find data to print
D HDR ; build HDR() array
D PRT
;
EXIT ;
K ^TMP("DGPFRFA1",$J)
I $D(ZTQUEUED) S ZTREQ="@"
I TRM D ^%ZISC
Q
;
;----------------------- PRIVATE SUBROUTINES -----------------------
A1 ;
; Find records using sort var's to build list
; Output:
; ^TMP("DGPFRFA1",$J) - temp global containing report output
;
N DGQ,DGSUB
S DGQ=0
; DGF="A" for all flags or is single variable pointer syntax
; ^DGPF(26.13,"AFLAG",DGSUB,dfn,ien)
I +DGF,'$D(^DGPF(26.13,"AFLAG",DGF)) Q
;
S DGSUB=0 I +DGF S DGSUB=$O(^DGPF(26.13,"AFLAG",DGF),-1)
F S DGSUB=$O(^DGPF(26.13,"AFLAG",DGSUB)) Q:DGSUB="" D Q:DGQ
. I +DGF,DGSUB'=DGF S DGQ=1 Q ; single flag
. I +DGC,DGSUB'[DGC Q ; single flag category
. ;
. N DGCNT,DGDFN,DGDFNLST
. ; now get all patients with DGSUB flag assignment
. ; dgdfnlst(dfn)=ien_file_26.13
. Q:'$$ASGNCNT^DGPFLF6(DGSUB,.DGDFNLST)
. S DGDFN=0 F S DGDFN=$O(DGDFNLST(DGDFN)) Q:DGDFN="" D
. . N X,Y,DGIEN,DGPFA,OWN,STAT
. . S DGIEN=DGDFNLST(DGDFN) Q:DGIEN=""
. . Q:'$$GETASGN^DGPFAA(DGIEN,.DGPFA)
. . ; filter, get history, save computed value in DGPFA()
. . I $$A11 D A12
. . Q
. Q
Q
;
A11() ; apply filters
; 1. Get all History records of certain ACTION types:
; 2: Action types: New, Inactivate, Reactivate, Enter in Error
; 3. Action DATE must be within date range
;
N X,Y,ACT,DATE,DEACT,DGHST,IEN,LAST,NUM
; check STATUS
S X=+$G(DGPFA("STATUS")) I X'=DGS Q 0
; check type of owner
S X=+$G(DGPFA("OWNER")),Y=0 I X>0 S Y=$$ISDIV^DGPFUT(X)
I DGO>0 I '$S(DGO=2:Y<1,1:Y>0) Q 0
; get all History records of the desired ACTION
I '$$ACTFILT^DGPFAAH2("DGHST",DGIEN,"1;3;4;5",,"D") Q 0
; filter records by date range and action
; LAST(1) = last activation action date
; LAST(3) = last inactivation action date
; LAST(2) = first inactivation action after last activation action
; count total number of activation events within time range
S (LAST(1),LAST(2),LAST(3),NUM)=""
S DATE=0 F S DATE=$O(DGHST(DATE)) Q:'DATE D
. S Y=DATE\1
. I Y<DGBEG K DGHST(DATE) S DGHST=DGHST-1 Q
. I Y>DGEND K DGHST(DATE) S DGHST=DGHST-1 Q
. S IEN=0 F S IEN=$O(DGHST(DATE,IEN)) Q:'IEN D
. . S X=+$G(DGHST(DATE,IEN,"ACTION"))
. . I "^1^3^4^5^"'[(U_X_U) Q
. . S Y=DATE\1
. . I (X=1)!(X=4) D
. . . S NUM=NUM+1 ; number of activations
. . . S LAST(1)=Y,LAST(2)=0 ; last activation action
. . . Q
. . I (X=3)!(X=5) D
. . . S LAST(3)=Y ; last inactivation action
. . . ; first inactivation action after last activation action
. . . I +LAST(1),'LAST(2),Y'<LAST(1) S LAST(2)=Y
. . . Q
. . Q
. Q
I 'DGHST Q 0 ; no history records within date range
I 'NUM Q 0 ; no activations within date range
S DGPFA("ztimesactive")=NUM
S DGPFA("zlastdate")=LAST(1)
S Y="" I LAST(1) D
. S:'LAST(2) LAST(2)=DT
. S Y=$$FMDIFF^XLFDT(LAST(2),LAST(1),1)+1
. Q
S DGPFA("zdaysactive")=Y
S DGPFA("zlastinact")=LAST(3)
Q 1
;
A12 ; build the list global
; Output:
; ^TMP("DGPFRFA1",$J) - temp global containing report output
;
N I,X,Y,DATE,DGNAME,DGTMP,VAL
Q:'$$GETPAT^DGPFUT2(DGDFN,.DGTMP)
S DGNAME=DGTMP("NAME")
; set VAL = 9 '^'-pieces to save in global
; p1 = patient name
; p2 = 1U4N
; p3 = New Assignment date
; p4 = last activation date
; p5 = number of days last activation active
; p6 = next review date (may be null)
; p7 = review overdue?
; p8 = number of times assignment was activated in date range
; p9 = current owner of the assignment
; p10 = last date of inactivation
;
S VAL=DGNAME_U_$E(DGTMP("NAME"))_$E(DGTMP("SSN"),6,10)
K DGTMP
; retrieve initial history assign record
Q:'$$GETHIST^DGPFAAH($$GETFIRST^DGPFAAH(DGIEN),.DGTMP)
;-- get 'initial assignment' date
S DATE=$P($P($G(DGTMP("ASSIGNDT")),U),".")
S:DATE DATE=$$FMTE^XLFDT(DATE,"2Z")
S $P(VAL,U,3)=DATE
;
S DATE=$G(DGPFA("zlastdate"))
S:DATE DATE=$$FMTE^XLFDT(DATE,"2Z")
S $P(VAL,U,4)=DATE
;
; days active, if assign inactive , put days active in ()
S X=$G(DGPFA("zdaysactive")) I X,DGS=0 S X="("_X_")"
S $P(VAL,U,5)=X
;
S DATE="",Y=$P($G(DGPFA("REVIEWDT")),U)
S:Y DATE=$$FMTE^XLFDT(Y,"2Z")
S $P(VAL,U,6)=DATE
;
S $P(VAL,U,7)=$S('Y:"N/A",Y<DT:"Yes",1:"No")
;
S $P(VAL,U,8)=$G(DGPFA("ztimesactive"))
;
S X=$P($G(DGPFA("OWNER")),U,2) S:$L(X) $P(VAL,U,9)=X
;
S Y=$G(DGPFA("zlastinact")) S:Y $P(VAL,U,10)=$$FMTE^XLFDT(Y,"2Z")
;
; construct nodes to sort return global
N CAT,FLAG
S FLAG=$G(DGPFA("FLAG")) Q:FLAG=""
S CAT=$S(FLAG[26.15:1,1:2)
S FLAG=$P(FLAG,U,2)
S @DGLIST@(CAT,FLAG,DGNAME,DGDFN)=VAL
Q
;
FORMAT(VAL) ; format one row of data for display
N I,L,P,COL,DAT,STR
F I=1:1:10 S DAT(I)=$P(VAL,U,I)
S COL=1,STR=DAT(1) ; patient name
S COL=33,$E(STR,COL)=$E(DAT(2),1,6) ; 1U4N
S COL=40,$E(STR,COL)=$E(DAT(3),1,8) ; init assign date
S COL=50,$E(STR,COL)=$E(DAT(4),1,8) ; last active date
S COL=60,$E(STR,COL)=$J($E(DAT(5),1,6),6) ; # days active
I +DGS S COL=68,$E(STR,COL)=$E(DAT(6),1,8) ; review date
I +DGS S COL=81,$E(STR,COL)=$E(DAT(7),1,5) ; overdue?
I 'DGS S COL=68,$E(STR,COL)=$E(DAT(10),1,8) ; inactivation date
S COL=$S(DGS:88,1:80),$E(STR,COL)=$J($E(DAT(8),1,7),7) ;#times activat
S COL=$S(DGS:100,1:92),$E(STR,COL)=$E(DAT(9),1,30) ; current own site
S:$L(STR)<132 $E(STR,132)=" "
S:$L(STR)>132 STR=$E(STR,1,132)
Q STR
;
HDR ; build header array
; see sample header at end of routine
; S $E(X,start_pos)=value
; Active header: 1,33,40,50,60,68,79,89,100
; Inactive header: 1,33,40,50,60,58,80,92
N I,L,X,Y,COL,ROW
K HDR
S ROW=1 S HDR(ROW)="Flag Assignment Report",$E(HDR(ROW),123)="Page: "
S ROW=2 S $P(HDR(ROW),"=",133)=""
S ROW=3 D
. S X="CATEGORY: " D
. . S Y="I & II (National/Local)"
. . I +DGC S Y=$S(DGC=26.15:"I (National)",1:"II (Local)")
. . S HDR(ROW)=X_Y
. . Q
. S COL=39,$E(HDR(ROW),COL)="STATUS: "_$P(DGSORT("DGSTAT"),U,2)
. S COL=69,X="OWNERSHIP: " D
. . S Y=$P("All^Local^Other",U,DGO+1)_" Facilit"_$S(+DGO:"y",1:"ies")
. . S $E(HDR(ROW),COL)=X_Y
. . Q
. S COL=99,X="DATE RANGE: " D
. . S Y=$$FMTE^XLFDT(DGBEG,"2Z")_" to "_$$FMTE^XLFDT(DGEND,"2Z")
. . S $E(HDR(ROW),COL)=X_Y
. . Q
. Q
S ROW=4 D
. I +DGF S HDR(ROW)=" FLAG: "_$P(DGSORT("DGFLAG"),U,2)
. S COL=102,$E(HDR(ROW),COL)="PRINTED: "_$$FMTE^XLFDT(DT,"Z")
. Q
S ROW=5,HDR(ROW)=HDR(2)
S ROW=6 D
. ; inactive only report has different column headers
. S X=""
. S COL=40,$E(X,COL)="Orig"
. S COL=50,$E(X,COL)="Last"
. S COL=60,$E(X,COL)="# Days"
. I +DGS S COL=89,$E(X,COL)="# Times"
. I 'DGS D ; inactive report
. . S COL=68,$E(X,COL)="Inactivate"
. . S COL=80,$E(X,COL)="# Times"
. . Q
. S $E(X,132)=" "
. S HDR(ROW)=X
S ROW=7 D
. S X="Patient Name"
. S COL=33,$E(X,COL)="SSN"
. S COL=40,$E(X,COL)="AssignDT"
. S COL=50,$E(X,COL)="AssignDT"
. S COL=60,$E(X,COL)="Active"
. I +DGS D ; active only report
. . S COL=68,$E(X,COL)="Review On"
. . S COL=79,$E(X,COL)="Overdue?"
. . S COL=89,$E(X,COL)="Activated"
. . S COL=100,$E(X,COL)="Current Owning Site"
. . Q
. I 'DGS D ; inactive only report
. . S COL=68,$E(X,COL)="Date"
. . S COL=80,$E(X,COL)="Activated"
. . S COL=92,$E(X,COL)="Current Owning Site"
. . Q
. S $E(X,132)=" "
. S HDR(ROW)=X
. Q
S ROW=8,HDR(ROW)=$TR(HDR(2),"=","-")
Q
;
PRT ;
; DGLIST = ^TMP("DGPFRFA1",$J,CAT,FLAG,DGNAME,DGDFN)
N I,X,Y,DGQ,GR,PAGE,STOP,SUBHD,TOTAL
N CAT,CAT0,FLAG,FLAG0
S (DGQ,PAGE)=0
S SUBHD=(DGSORT("DGFLAG")<1)
D WRHDR
I $O(@DGLIST@(""))="" D G PRTOUT
. S X="No Record Flag Assignments found using the report criteria."
. W !!," >>> "_X,!
. Q
;
S GR=DGLIST,STOP=$TR(GR,")",",")
S (CAT0,FLAG0)=""
;
F S GR=$Q(@GR) Q:(GR'[STOP) D Q:DGQ
. N X,DATA,DFN,FLAG,PNAM
. S CAT=$QS(GR,3)
. S FLAG=$QS(GR,4)
. S PNAM=$QS(GR,5)
. S DFN=$QS(GR,6)
. S DATA=@GR
. ; need to write subheader for next flag?
. ; no subheader for single flag report
. I SUBHD,CAT'=CAT0!(FLAG'=FLAG0) D WRSUBHDR Q:DGQ
. ; update totals
. S TOTAL(CAT)=1+$G(TOTAL(CAT))
. S TOTAL(CAT,FLAG)=1+$G(TOTAL(CAT,FLAG))
. S CAT0=CAT,FLAG0=FLAG
. S X=$$FORMAT(DATA) D WR(X)
. Q
I 'DGQ D WRTOT
;
PRTOUT ;
I TRM,'DGQ W ! S X=$$E^DGPFUT7
Q
;
WR(X) ; write out one line
; check for bottom of page
; write new header if necessary
W !,X D WRCK() I 'DGQ,(IOSL-$Y)<4 D WRHDR
Q
;
WRCK(MIN) ; check to see if we should quit printing (set DGQ=1)
; Input Parameters:
; MIN - optional - minimal number of lines needed before end of page
; default to 4
I 'TRM Q
S MIN=$G(MIN) S:'MIN MIN=4 S MIN=MIN+1
I MIN>0,(IOSL-$Y)'<MIN Q
N Z S Z=$$E^DGPFUT7 I Z<1 S DGQ=1
Q
;
WRHDR ; write page header, increment page count
I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQ)=1
Q:DGQ
N I
S PAGE=1+PAGE
I PAGE=1,TRM W @IOF
I PAGE>1 W @IOF
W !,HDR(1)_PAGE
I PAGE=1 F I=2:1:8 W !,HDR(I)
I PAGE>1 F I=2,6,7,8 W !,HDR(I)
Q
;
WRSUBHDR ; write subheader of category or flag name
D WRCK Q:DGQ
N X,Y
S Y=$S(CAT=1:"I (National)",1:"II (Local)")
S X=" Flag: "_FLAG_" [Category "_Y_"]"
W !!,X
Q
;
WRTOT ; write out totals
N I,L,X,Y,FL,SUM
S SUM(1)=" -----------------------------------------------"
S SUM(2)=" SUMMARY OF TOTAL ASSIGNMENTS"
S SUM(3)=SUM(1)
S L=3
F I=1,2 I $G(TOTAL(I))>0 D
. S X=" Category "_$P("I (National)^II (Local)",U,I)
. S $E(X,39)=":"_$J(TOTAL(I),7)
. S L=L+1,SUM(L)=X
. S FL="" F S FL=$O(TOTAL(I,FL)) Q:FL="" D
. . S X=" "_FL
. . S $E(X,39)=":"_$J(TOTAL(I,FL),7)
. . S L=L+1,SUM(L)=X
. . Q
. I I=1,$D(TOTAL(2)) S L=L+1,SUM(L)=SUM(1)
. Q
;
; print summary on one page if possible
I (IOSL-$Y-L)<0 D WRHDR Q:DGQ
W ! F I=1:1:L D:(IOSL-$Y-(L-I))<0 WRHDR Q:DGQ W !,SUM(I)
Q
;
WRX ; press [ENTER] to continue
Q:'TRM
N L,X,Y,DIR,DIROUT,DIRUT,DTOUT,DUOUT
W ! S DIR(0)="E" D ^DIR S:$D(DTOUT)!$D(DUOUT) DGQ=1
Q
;
WR2 ; write subtotals for flag
Q
I DGQ Q
N X,Y
S X=" Total Assignments for flag "_FLAG0_" [Category "
S Y=$S(CAT0=1:"I (National)",1:"II (Local)")
S X=X_Y_"]: "_(+$G(TOTAL(CAT0,FLAG0)))
S Y=" "_$TR($E(LINE,1,$L(X)-5),"-","=")
; do not allow subtotals to print on 2 pages
I (IOSL-$Y)<4 D WR()
I 'DGQ W !!,X,!,Y,!
Q
;
; Sample Header
; 1 2 3 4 5 6 7 8 9 0 1 2 3
;123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012
;Flag Assignment Report Page: 1
;====================================================================================================================================
;CATEGORY: I & II (National/Local) STATUS: Inactive OWNERSHIP: All Facilities DATE RANGE: 07/07/15 to 06/26/18
; PRINTED: Jun 26, 2018
;====================================================================================================================================
; Orig Activated Days # Times
;Patient Name SSN AssignDT On Active Review On Overdue? Activated Current Owning Site
;------------------------------------------------------------------------------------------------------------------------------------
;
; Flag: HIGH RISK FOR SUICIDE [Category I (National)]
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFRFA1 14085 printed Sep 23, 2025@20:24:31 Page 2
DGPFRFA1 ;ALB/RBS - PRF FLAG ASSIGNMENT REPORT CONT. ; 1/21/04 5:14pm
+1 ;;5.3;Registration;**425,554,960**;Aug 13, 1993;Build 22
+2 ; Last Edited: SHRPE/sgm - Jul 9, 2018 13:30
+3 ;
+4 ; ICR# TYPE DESCRIPTION
+5 ;----- ---- ---------------------------------
+6 ;10024 Sup WAIT^DICD
+7 ;10026 Sup ^DIR
+8 ;10086 Sup HOME^%ZIS
+9 ;10103 Sup ^XLFDT: $$FMDIFF, $$FMTE, $$NOW
+10 ;10063 Sup $$S^%ZTLOAD
+11 ;
+12 ;This routine will compile and produce the FLAG ASSIGNMENT REPORT.
+13 ;This routine will be used to display or print all of the patient
+14 ; assignments for Category I and Category II Patient Record Flags.
+15 ;
+16 ;All sort input was created in routine DGPFRFA passed by Taskman
+17 ; Input: The following array contains the sort var's:
+18 ;
+19 ; DGSORT(subscript)=value [see routine DGPFRFA for details]
+20 ;
+21 ; Output: A formatted report of Record Flag Assignments to patients.
+22 ;5/1/2018 - DG*5.3*960 - report format substantially changed
+23 ;- no direct entry
+24 QUIT
+25 ;
START ; compile and print report
+1 NEW DGLIST,HDR,LINE,TRM,ZTSTOP
+2 NEW DGC,DGF,DGO,DGS,DGBEG,DGEND
+3 SET ZTSTOP=0
+4 KILL ^TMP("DGPFRFA1",$JOB)
+5 SET DGLIST=$NAME(^TMP("DGPFRFA1",$JOB))
+6 SET $PIECE(LINE,"-",104)=""
+7 ;
+8 ; convert some DGSORT() to convenient local variables
Begin DoDot:1
+9 ; DGC, DGF, DGO, DGS
+10 ; Category, Flag, Ownership, Status
+11 NEW X
+12 SET (DGBEG,DGC,DGEND,DGF,DGO,DGS)=""
+13 ; convert category to 0 or file# of variable pointer
+14 SET X=+DGSORT("DGCAT")
SET DGC=$SELECT(X=3:0,X=1:26.15,1:26.11)
+15 ;
+16 ; convert ownership to 1:Local; 2:Other; 0:Both
+17 SET X=+DGSORT("DGOWN")
SET DGO=$SELECT(X=3:0,1:X)
+18 ;
+19 ; status 0:Inactive 1:Active
+20 ; reset so coordinated with ^DD(26.13)
+21 SET DGS=(+DGSORT("DGSTAT")=1)
+22 ;
+23 ; DGF = A:all or variable pointer syntax for single flag
+24 SET DGF=$PIECE(DGSORT("DGFLAG"),U)
+25 SET DGBEG=(DGSORT("DGBEG")\1)
+26 SET DGEND=(DGSORT("DGEND")\1)
+27 QUIT
End DoDot:1
+28 ;
+29 SET TRM=($EXTRACT(IOST)="C")
IF TRM
DO WAIT^DICD
+30 ; START module initialized 6 local variables used by next code
+31 ; find data to print
DO A1
+32 ; build HDR() array
DO HDR
+33 DO PRT
+34 ;
EXIT ;
+1 KILL ^TMP("DGPFRFA1",$JOB)
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 IF TRM
DO ^%ZISC
+4 QUIT
+5 ;
+6 ;----------------------- PRIVATE SUBROUTINES -----------------------
A1 ;
+1 ; Find records using sort var's to build list
+2 ; Output:
+3 ; ^TMP("DGPFRFA1",$J) - temp global containing report output
+4 ;
+5 NEW DGQ,DGSUB
+6 SET DGQ=0
+7 ; DGF="A" for all flags or is single variable pointer syntax
+8 ; ^DGPF(26.13,"AFLAG",DGSUB,dfn,ien)
+9 IF +DGF
IF '$DATA(^DGPF(26.13,"AFLAG",DGF))
QUIT
+10 ;
+11 SET DGSUB=0
IF +DGF
SET DGSUB=$ORDER(^DGPF(26.13,"AFLAG",DGF),-1)
+12 FOR
SET DGSUB=$ORDER(^DGPF(26.13,"AFLAG",DGSUB))
if DGSUB=""
QUIT
Begin DoDot:1
+13 ; single flag
IF +DGF
IF DGSUB'=DGF
SET DGQ=1
QUIT
+14 ; single flag category
IF +DGC
IF DGSUB'[DGC
QUIT
+15 ;
+16 NEW DGCNT,DGDFN,DGDFNLST
+17 ; now get all patients with DGSUB flag assignment
+18 ; dgdfnlst(dfn)=ien_file_26.13
+19 if '$$ASGNCNT^DGPFLF6(DGSUB,.DGDFNLST)
QUIT
+20 SET DGDFN=0
FOR
SET DGDFN=$ORDER(DGDFNLST(DGDFN))
if DGDFN=""
QUIT
Begin DoDot:2
+21 NEW X,Y,DGIEN,DGPFA,OWN,STAT
+22 SET DGIEN=DGDFNLST(DGDFN)
if DGIEN=""
QUIT
+23 if '$$GETASGN^DGPFAA(DGIEN,.DGPFA)
QUIT
+24 ; filter, get history, save computed value in DGPFA()
+25 IF $$A11
DO A12
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
if DGQ
QUIT
+28 QUIT
+29 ;
A11() ; apply filters
+1 ; 1. Get all History records of certain ACTION types:
+2 ; 2: Action types: New, Inactivate, Reactivate, Enter in Error
+3 ; 3. Action DATE must be within date range
+4 ;
+5 NEW X,Y,ACT,DATE,DEACT,DGHST,IEN,LAST,NUM
+6 ; check STATUS
+7 SET X=+$GET(DGPFA("STATUS"))
IF X'=DGS
QUIT 0
+8 ; check type of owner
+9 SET X=+$GET(DGPFA("OWNER"))
SET Y=0
IF X>0
SET Y=$$ISDIV^DGPFUT(X)
+10 IF DGO>0
IF '$SELECT(DGO=2:Y<1,1:Y>0)
QUIT 0
+11 ; get all History records of the desired ACTION
+12 IF '$$ACTFILT^DGPFAAH2("DGHST",DGIEN,"1;3;4;5",,"D")
QUIT 0
+13 ; filter records by date range and action
+14 ; LAST(1) = last activation action date
+15 ; LAST(3) = last inactivation action date
+16 ; LAST(2) = first inactivation action after last activation action
+17 ; count total number of activation events within time range
+18 SET (LAST(1),LAST(2),LAST(3),NUM)=""
+19 SET DATE=0
FOR
SET DATE=$ORDER(DGHST(DATE))
if 'DATE
QUIT
Begin DoDot:1
+20 SET Y=DATE\1
+21 IF Y<DGBEG
KILL DGHST(DATE)
SET DGHST=DGHST-1
QUIT
+22 IF Y>DGEND
KILL DGHST(DATE)
SET DGHST=DGHST-1
QUIT
+23 SET IEN=0
FOR
SET IEN=$ORDER(DGHST(DATE,IEN))
if 'IEN
QUIT
Begin DoDot:2
+24 SET X=+$GET(DGHST(DATE,IEN,"ACTION"))
+25 IF "^1^3^4^5^"'[(U_X_U)
QUIT
+26 SET Y=DATE\1
+27 IF (X=1)!(X=4)
Begin DoDot:3
+28 ; number of activations
SET NUM=NUM+1
+29 ; last activation action
SET LAST(1)=Y
SET LAST(2)=0
+30 QUIT
End DoDot:3
+31 IF (X=3)!(X=5)
Begin DoDot:3
+32 ; last inactivation action
SET LAST(3)=Y
+33 ; first inactivation action after last activation action
+34 IF +LAST(1)
IF 'LAST(2)
IF Y'<LAST(1)
SET LAST(2)=Y
+35 QUIT
End DoDot:3
+36 QUIT
End DoDot:2
+37 QUIT
End DoDot:1
+38 ; no history records within date range
IF 'DGHST
QUIT 0
+39 ; no activations within date range
IF 'NUM
QUIT 0
+40 SET DGPFA("ztimesactive")=NUM
+41 SET DGPFA("zlastdate")=LAST(1)
+42 SET Y=""
IF LAST(1)
Begin DoDot:1
+43 if 'LAST(2)
SET LAST(2)=DT
+44 SET Y=$$FMDIFF^XLFDT(LAST(2),LAST(1),1)+1
+45 QUIT
End DoDot:1
+46 SET DGPFA("zdaysactive")=Y
+47 SET DGPFA("zlastinact")=LAST(3)
+48 QUIT 1
+49 ;
A12 ; build the list global
+1 ; Output:
+2 ; ^TMP("DGPFRFA1",$J) - temp global containing report output
+3 ;
+4 NEW I,X,Y,DATE,DGNAME,DGTMP,VAL
+5 if '$$GETPAT^DGPFUT2(DGDFN,.DGTMP)
QUIT
+6 SET DGNAME=DGTMP("NAME")
+7 ; set VAL = 9 '^'-pieces to save in global
+8 ; p1 = patient name
+9 ; p2 = 1U4N
+10 ; p3 = New Assignment date
+11 ; p4 = last activation date
+12 ; p5 = number of days last activation active
+13 ; p6 = next review date (may be null)
+14 ; p7 = review overdue?
+15 ; p8 = number of times assignment was activated in date range
+16 ; p9 = current owner of the assignment
+17 ; p10 = last date of inactivation
+18 ;
+19 SET VAL=DGNAME_U_$EXTRACT(DGTMP("NAME"))_$EXTRACT(DGTMP("SSN"),6,10)
+20 KILL DGTMP
+21 ; retrieve initial history assign record
+22 if '$$GETHIST^DGPFAAH($$GETFIRST^DGPFAAH(DGIEN),.DGTMP)
QUIT
+23 ;-- get 'initial assignment' date
+24 SET DATE=$PIECE($PIECE($GET(DGTMP("ASSIGNDT")),U),".")
+25 if DATE
SET DATE=$$FMTE^XLFDT(DATE,"2Z")
+26 SET $PIECE(VAL,U,3)=DATE
+27 ;
+28 SET DATE=$GET(DGPFA("zlastdate"))
+29 if DATE
SET DATE=$$FMTE^XLFDT(DATE,"2Z")
+30 SET $PIECE(VAL,U,4)=DATE
+31 ;
+32 ; days active, if assign inactive , put days active in ()
+33 SET X=$GET(DGPFA("zdaysactive"))
IF X
IF DGS=0
SET X="("_X_")"
+34 SET $PIECE(VAL,U,5)=X
+35 ;
+36 SET DATE=""
SET Y=$PIECE($GET(DGPFA("REVIEWDT")),U)
+37 if Y
SET DATE=$$FMTE^XLFDT(Y,"2Z")
+38 SET $PIECE(VAL,U,6)=DATE
+39 ;
+40 SET $PIECE(VAL,U,7)=$SELECT('Y:"N/A",Y<DT:"Yes",1:"No")
+41 ;
+42 SET $PIECE(VAL,U,8)=$GET(DGPFA("ztimesactive"))
+43 ;
+44 SET X=$PIECE($GET(DGPFA("OWNER")),U,2)
if $LENGTH(X)
SET $PIECE(VAL,U,9)=X
+45 ;
+46 SET Y=$GET(DGPFA("zlastinact"))
if Y
SET $PIECE(VAL,U,10)=$$FMTE^XLFDT(Y,"2Z")
+47 ;
+48 ; construct nodes to sort return global
+49 NEW CAT,FLAG
+50 SET FLAG=$GET(DGPFA("FLAG"))
if FLAG=""
QUIT
+51 SET CAT=$SELECT(FLAG[26.15:1,1:2)
+52 SET FLAG=$PIECE(FLAG,U,2)
+53 SET @DGLIST@(CAT,FLAG,DGNAME,DGDFN)=VAL
+54 QUIT
+55 ;
FORMAT(VAL) ; format one row of data for display
+1 NEW I,L,P,COL,DAT,STR
+2 FOR I=1:1:10
SET DAT(I)=$PIECE(VAL,U,I)
+3 ; patient name
SET COL=1
SET STR=DAT(1)
+4 ; 1U4N
SET COL=33
SET $EXTRACT(STR,COL)=$EXTRACT(DAT(2),1,6)
+5 ; init assign date
SET COL=40
SET $EXTRACT(STR,COL)=$EXTRACT(DAT(3),1,8)
+6 ; last active date
SET COL=50
SET $EXTRACT(STR,COL)=$EXTRACT(DAT(4),1,8)
+7 ; # days active
SET COL=60
SET $EXTRACT(STR,COL)=$JUSTIFY($EXTRACT(DAT(5),1,6),6)
+8 ; review date
IF +DGS
SET COL=68
SET $EXTRACT(STR,COL)=$EXTRACT(DAT(6),1,8)
+9 ; overdue?
IF +DGS
SET COL=81
SET $EXTRACT(STR,COL)=$EXTRACT(DAT(7),1,5)
+10 ; inactivation date
IF 'DGS
SET COL=68
SET $EXTRACT(STR,COL)=$EXTRACT(DAT(10),1,8)
+11 ;#times activat
SET COL=$SELECT(DGS:88,1:80)
SET $EXTRACT(STR,COL)=$JUSTIFY($EXTRACT(DAT(8),1,7),7)
+12 ; current own site
SET COL=$SELECT(DGS:100,1:92)
SET $EXTRACT(STR,COL)=$EXTRACT(DAT(9),1,30)
+13 if $LENGTH(STR)<132
SET $EXTRACT(STR,132)=" "
+14 if $LENGTH(STR)>132
SET STR=$EXTRACT(STR,1,132)
+15 QUIT STR
+16 ;
HDR ; build header array
+1 ; see sample header at end of routine
+2 ; S $E(X,start_pos)=value
+3 ; Active header: 1,33,40,50,60,68,79,89,100
+4 ; Inactive header: 1,33,40,50,60,58,80,92
+5 NEW I,L,X,Y,COL,ROW
+6 KILL HDR
+7 SET ROW=1
SET HDR(ROW)="Flag Assignment Report"
SET $EXTRACT(HDR(ROW),123)="Page: "
+8 SET ROW=2
SET $PIECE(HDR(ROW),"=",133)=""
+9 SET ROW=3
Begin DoDot:1
+10 SET X="CATEGORY: "
Begin DoDot:2
+11 SET Y="I & II (National/Local)"
+12 IF +DGC
SET Y=$SELECT(DGC=26.15:"I (National)",1:"II (Local)")
+13 SET HDR(ROW)=X_Y
+14 QUIT
End DoDot:2
+15 SET COL=39
SET $EXTRACT(HDR(ROW),COL)="STATUS: "_$PIECE(DGSORT("DGSTAT"),U,2)
+16 SET COL=69
SET X="OWNERSHIP: "
Begin DoDot:2
+17 SET Y=$PIECE("All^Local^Other",U,DGO+1)_" Facilit"_$SELECT(+DGO:"y",1:"ies")
+18 SET $EXTRACT(HDR(ROW),COL)=X_Y
+19 QUIT
End DoDot:2
+20 SET COL=99
SET X="DATE RANGE: "
Begin DoDot:2
+21 SET Y=$$FMTE^XLFDT(DGBEG,"2Z")_" to "_$$FMTE^XLFDT(DGEND,"2Z")
+22 SET $EXTRACT(HDR(ROW),COL)=X_Y
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
+25 SET ROW=4
Begin DoDot:1
+26 IF +DGF
SET HDR(ROW)=" FLAG: "_$PIECE(DGSORT("DGFLAG"),U,2)
+27 SET COL=102
SET $EXTRACT(HDR(ROW),COL)="PRINTED: "_$$FMTE^XLFDT(DT,"Z")
+28 QUIT
End DoDot:1
+29 SET ROW=5
SET HDR(ROW)=HDR(2)
+30 SET ROW=6
Begin DoDot:1
+31 ; inactive only report has different column headers
+32 SET X=""
+33 SET COL=40
SET $EXTRACT(X,COL)="Orig"
+34 SET COL=50
SET $EXTRACT(X,COL)="Last"
+35 SET COL=60
SET $EXTRACT(X,COL)="# Days"
+36 IF +DGS
SET COL=89
SET $EXTRACT(X,COL)="# Times"
+37 ; inactive report
IF 'DGS
Begin DoDot:2
+38 SET COL=68
SET $EXTRACT(X,COL)="Inactivate"
+39 SET COL=80
SET $EXTRACT(X,COL)="# Times"
+40 QUIT
End DoDot:2
+41 SET $EXTRACT(X,132)=" "
+42 SET HDR(ROW)=X
End DoDot:1
+43 SET ROW=7
Begin DoDot:1
+44 SET X="Patient Name"
+45 SET COL=33
SET $EXTRACT(X,COL)="SSN"
+46 SET COL=40
SET $EXTRACT(X,COL)="AssignDT"
+47 SET COL=50
SET $EXTRACT(X,COL)="AssignDT"
+48 SET COL=60
SET $EXTRACT(X,COL)="Active"
+49 ; active only report
IF +DGS
Begin DoDot:2
+50 SET COL=68
SET $EXTRACT(X,COL)="Review On"
+51 SET COL=79
SET $EXTRACT(X,COL)="Overdue?"
+52 SET COL=89
SET $EXTRACT(X,COL)="Activated"
+53 SET COL=100
SET $EXTRACT(X,COL)="Current Owning Site"
+54 QUIT
End DoDot:2
+55 ; inactive only report
IF 'DGS
Begin DoDot:2
+56 SET COL=68
SET $EXTRACT(X,COL)="Date"
+57 SET COL=80
SET $EXTRACT(X,COL)="Activated"
+58 SET COL=92
SET $EXTRACT(X,COL)="Current Owning Site"
+59 QUIT
End DoDot:2
+60 SET $EXTRACT(X,132)=" "
+61 SET HDR(ROW)=X
+62 QUIT
End DoDot:1
+63 SET ROW=8
SET HDR(ROW)=$TRANSLATE(HDR(2),"=","-")
+64 QUIT
+65 ;
PRT ;
+1 ; DGLIST = ^TMP("DGPFRFA1",$J,CAT,FLAG,DGNAME,DGDFN)
+2 NEW I,X,Y,DGQ,GR,PAGE,STOP,SUBHD,TOTAL
+3 NEW CAT,CAT0,FLAG,FLAG0
+4 SET (DGQ,PAGE)=0
+5 SET SUBHD=(DGSORT("DGFLAG")<1)
+6 DO WRHDR
+7 IF $ORDER(@DGLIST@(""))=""
Begin DoDot:1
+8 SET X="No Record Flag Assignments found using the report criteria."
+9 WRITE !!," >>> "_X,!
+10 QUIT
End DoDot:1
GOTO PRTOUT
+11 ;
+12 SET GR=DGLIST
SET STOP=$TRANSLATE(GR,")",",")
+13 SET (CAT0,FLAG0)=""
+14 ;
+15 FOR
SET GR=$QUERY(@GR)
if (GR'[STOP)
QUIT
Begin DoDot:1
+16 NEW X,DATA,DFN,FLAG,PNAM
+17 SET CAT=$QSUBSCRIPT(GR,3)
+18 SET FLAG=$QSUBSCRIPT(GR,4)
+19 SET PNAM=$QSUBSCRIPT(GR,5)
+20 SET DFN=$QSUBSCRIPT(GR,6)
+21 SET DATA=@GR
+22 ; need to write subheader for next flag?
+23 ; no subheader for single flag report
+24 IF SUBHD
IF CAT'=CAT0!(FLAG'=FLAG0)
DO WRSUBHDR
if DGQ
QUIT
+25 ; update totals
+26 SET TOTAL(CAT)=1+$GET(TOTAL(CAT))
+27 SET TOTAL(CAT,FLAG)=1+$GET(TOTAL(CAT,FLAG))
+28 SET CAT0=CAT
SET FLAG0=FLAG
+29 SET X=$$FORMAT(DATA)
DO WR(X)
+30 QUIT
End DoDot:1
if DGQ
QUIT
+31 IF 'DGQ
DO WRTOT
+32 ;
PRTOUT ;
+1 IF TRM
IF 'DGQ
WRITE !
SET X=$$E^DGPFUT7
+2 QUIT
+3 ;
WR(X) ; write out one line
+1 ; check for bottom of page
+2 ; write new header if necessary
+3 WRITE !,X
DO WRCK()
IF 'DGQ
IF (IOSL-$Y)<4
DO WRHDR
+4 QUIT
+5 ;
WRCK(MIN) ; check to see if we should quit printing (set DGQ=1)
+1 ; Input Parameters:
+2 ; MIN - optional - minimal number of lines needed before end of page
+3 ; default to 4
+4 IF 'TRM
QUIT
+5 SET MIN=$GET(MIN)
if 'MIN
SET MIN=4
SET MIN=MIN+1
+6 IF MIN>0
IF (IOSL-$Y)'<MIN
QUIT
+7 NEW Z
SET Z=$$E^DGPFUT7
IF Z<1
SET DGQ=1
+8 QUIT
+9 ;
WRHDR ; write page header, increment page count
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,DGQ)=1
+2 if DGQ
QUIT
+3 NEW I
+4 SET PAGE=1+PAGE
+5 IF PAGE=1
IF TRM
WRITE @IOF
+6 IF PAGE>1
WRITE @IOF
+7 WRITE !,HDR(1)_PAGE
+8 IF PAGE=1
FOR I=2:1:8
WRITE !,HDR(I)
+9 IF PAGE>1
FOR I=2,6,7,8
WRITE !,HDR(I)
+10 QUIT
+11 ;
WRSUBHDR ; write subheader of category or flag name
+1 DO WRCK
if DGQ
QUIT
+2 NEW X,Y
+3 SET Y=$SELECT(CAT=1:"I (National)",1:"II (Local)")
+4 SET X=" Flag: "_FLAG_" [Category "_Y_"]"
+5 WRITE !!,X
+6 QUIT
+7 ;
WRTOT ; write out totals
+1 NEW I,L,X,Y,FL,SUM
+2 SET SUM(1)=" -----------------------------------------------"
+3 SET SUM(2)=" SUMMARY OF TOTAL ASSIGNMENTS"
+4 SET SUM(3)=SUM(1)
+5 SET L=3
+6 FOR I=1,2
IF $GET(TOTAL(I))>0
Begin DoDot:1
+7 SET X=" Category "_$PIECE("I (National)^II (Local)",U,I)
+8 SET $EXTRACT(X,39)=":"_$JUSTIFY(TOTAL(I),7)
+9 SET L=L+1
SET SUM(L)=X
+10 SET FL=""
FOR
SET FL=$ORDER(TOTAL(I,FL))
if FL=""
QUIT
Begin DoDot:2
+11 SET X=" "_FL
+12 SET $EXTRACT(X,39)=":"_$JUSTIFY(TOTAL(I,FL),7)
+13 SET L=L+1
SET SUM(L)=X
+14 QUIT
End DoDot:2
+15 IF I=1
IF $DATA(TOTAL(2))
SET L=L+1
SET SUM(L)=SUM(1)
+16 QUIT
End DoDot:1
+17 ;
+18 ; print summary on one page if possible
+19 IF (IOSL-$Y-L)<0
DO WRHDR
if DGQ
QUIT
+20 WRITE !
FOR I=1:1:L
if (IOSL-$Y-(L-I))<0
DO WRHDR
if DGQ
QUIT
WRITE !,SUM(I)
+21 QUIT
+22 ;
WRX ; press [ENTER] to continue
+1 if 'TRM
QUIT
+2 NEW L,X,Y,DIR,DIROUT,DIRUT,DTOUT,DUOUT
+3 WRITE !
SET DIR(0)="E"
DO ^DIR
if $DATA(DTOUT)!$DATA(DUOUT)
SET DGQ=1
+4 QUIT
+5 ;
WR2 ; write subtotals for flag
+1 QUIT
+2 IF DGQ
QUIT
+3 NEW X,Y
+4 SET X=" Total Assignments for flag "_FLAG0_" [Category "
+5 SET Y=$SELECT(CAT0=1:"I (National)",1:"II (Local)")
+6 SET X=X_Y_"]: "_(+$GET(TOTAL(CAT0,FLAG0)))
+7 SET Y=" "_$TRANSLATE($EXTRACT(LINE,1,$LENGTH(X)-5),"-","=")
+8 ; do not allow subtotals to print on 2 pages
+9 IF (IOSL-$Y)<4
DO WR()
+10 IF 'DGQ
WRITE !!,X,!,Y,!
+11 QUIT
+12 ;
+13 ; Sample Header
+14 ; 1 2 3 4 5 6 7 8 9 0 1 2 3
+15 ;123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012
+16 ;Flag Assignment Report Page: 1
+17 ;====================================================================================================================================
+18 ;CATEGORY: I & II (National/Local) STATUS: Inactive OWNERSHIP: All Facilities DATE RANGE: 07/07/15 to 06/26/18
+19 ; PRINTED: Jun 26, 2018
+20 ;====================================================================================================================================
+21 ; Orig Activated Days # Times
+22 ;Patient Name SSN AssignDT On Active Review On Overdue? Activated Current Owning Site
+23 ;------------------------------------------------------------------------------------------------------------------------------------
+24 ;
+25 ; Flag: HIGH RISK FOR SUICIDE [Category I (National)]
