ORPRF ;SLC/JLI/JMC -Patient record flag ;6/14/06
;;3.0;ORDER ENTRY/RESULTS REPORTING;**173,187,190,215,243,472,542**;Dec 17, 1997;Build 11
;
FMT(ROOT,DBRSDATA,DGHIST) ; Format - Convert record flag data to displayable data
; Sets ^TMP("ORPRF",$J,NN) with flag data for multiple flags
; DBRSDATA - local array with DBRS data
; DGHIST - local array with PRF history records
N IDX,IX,CNT,CURFLAG
S (IDX,CNT)=0
F S IDX=$O(ROOT(IDX)) Q:'IDX D
. S ^TMP("ORPRF",$J,IDX,"FLAG")=$P($G(ROOT(IDX,"FLAG")),U,2)
. S ^TMP("ORPRF",$J,IDX,"CATEGORY")=$P($G(ROOT(IDX,"CATEGORY")),U,2)
. S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Name: "_$P($G(ROOT(IDX,"FLAG")),U,2)
. I $D(ROOT(IDX,"NARR")) D
. . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=" "
. . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Assignment Narrative: "
. . S IX=0 F S IX=$O(ROOT(IDX,"NARR",IX)) Q:'IX D
. . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=$G(ROOT(IDX,"NARR",IX,0))
. S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=" "
. ; -- Assignment Details:
. S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Type: "_$P($G(ROOT(IDX,"FLAGTYPE")),U,2)
. S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Flag Category: "_$P($G(ROOT(IDX,"CATEGORY")),U,2)
. S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Assignment Status: "_"Active"
. S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Initial Assigned Date: "_$P($G(ROOT(IDX,"ASSIGNDT")),U,2)
. S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Approved by: "_$P($G(ROOT(IDX,"APPRVBY")),U,2)
. S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Next Review Date: "_$P($G(ROOT(IDX,"REVIEWDT")),U,2)
. S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Owner Site: "_$P($G(ROOT(IDX,"OWNER")),U,2)
. S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Originating Site: "_$P($G(ROOT(IDX,"ORIGSITE")),U,2)
. ;DBRS data
. I $O(DBRSDATA("BEHAVIORAL",0)) I $P($G(ROOT(IDX,"FLAG")),U,2)="BEHAVIORAL" D
. . N ORDBRSC,ORZDBRSD
. . S ORDBRSC=0 F S ORDBRSC=+$O(DBRSDATA("BEHAVIORAL",ORDBRSC)) Q:ORDBRSC=0 D
. . . S ORZDBRSD=$G(DBRSDATA("BEHAVIORAL",ORDBRSC))
. . . I $P(ORZDBRSD,U,1)']"" Q
. . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="DBRS number: "_$P(ORZDBRSD,U,1)
. . . I $P(ORZDBRSD,U,2)]"" S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Other DBRS data: "_$P(ORZDBRSD,U,2)
. ;check if any history for the PRF flag that is being processed now
. S CURFLAG=$P($G(ROOT(IDX,"FLAG")),U,2)
. I $O(DGHIST(CURFLAG,0)) D
. . N ORPRFHCN,ORPRFHDA,ORPRFSIT,ORQUIT
. . S ORPRFSIT="",ORQUIT=0
. . S ORPRFHCN=0 F S ORPRFHCN=+$O(DGHIST(CURFLAG,ORPRFHCN)) Q:ORPRFHCN=0!(ORQUIT=1) D Q:ORQUIT=1
. . . I $D(DGHIST(CURFLAG,ORPRFHCN)),ORPRFHCN>10 D Q:ORQUIT=1
. . . . S ORQUIT=1
. . . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="*** Additional information is in VistA ***"
. . . I ORPRFHCN=1 S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=""
. . . I ORPRFHCN=1 S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="History of Actions Taken:"
. . . I ORPRFHCN=1 S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="Date Action Site ID Site Name"
. . . I ORPRFHCN=1 S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)="------------------------------------------------"
. . . S ORPRFHDA=$G(DGHIST(CURFLAG,ORPRFHCN)) Q:ORPRFHDA=""
. . . ;I ORPRFSIT'=$P(ORPRFHDA,U) S ORPRFSIT=$P(ORPRFHDA,U) S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=ORPRFSIT_" changes:"
. . . S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=$P($P(ORPRFHDA,U,2),"@",1)_" "_$$LJ^XLFSTR($P(ORPRFHDA,U,3),15)_" "_$$LJ^XLFSTR($P(ORPRFHDA,U,4),8)_" "_$$LJ^XLFSTR($E($P(ORPRFHDA,U,1),1,20),30)
K ROOT
Q
;
HASFLG(ORY,PTDFN) ;Does patient PTDFN has flags
; DBIA 3860: $$GETACT^DGPFAPI(PTDFN,.FLGDATA)
; Returns array ORY listing active assigned flags
; Array ORY has form:
; ORY(flagID) = flagID^flagname,CAT1
; where CAT1 is 1 if flag is cat 1, 0 if cat 2
; ORY = Num of items returned in array ORY = num of flags
I '$L($TEXT(GETACT^DGPFAPI)) S ORY=0 Q
N IDY,PRFARR,CAT1
K ^TMP("ORPRF",$J)
S ORY=$$GETACT^DGPFAPI(PTDFN,"PRFARR")
Q:'ORY
;
N DBRSARR,PRFHIST
;ICR# 6874 - check if DG*5.3*951 installed and then call the API to get DBRS information
I $T(GETDBRS^DGPFDBRS)'="" I $$GETDBRS^DGPFDBRS(PTDFN,.DBRSARR)
;get history records for active PRFs
D ACTPRFHS^ORPRFHST(PTDFN,.PRFHIST)
;
D FMT(.@("PRFARR"),.DBRSARR,.PRFHIST) ; Sets ^TMP("ORPRF"
S IDY=0 F S IDY=$O(^TMP("ORPRF",$J,IDY)) Q:'IDY D
. S ORY(IDY)=IDY_U_$G(^TMP("ORPRF",$J,IDY,"FLAG"))
. S CAT1=0
. I $G(^TMP("ORPRF",$J,IDY,"CATEGORY"))="I (NATIONAL)" S CAT1=1
. S ORY(IDY)=ORY(IDY)_U_CAT1
Q
;
HASFLG1(ORY,PTDFN) ; Does patient PTDFN have **Cat I** flags
; Returns array ORY listing active assigned Cat I flags
; Array ORY has form:
; ORY(flagID) = flagID^flagname
; ORY = Num of Cat I flags
; If pt has no Cat I flags ORY = 0 and no flags are returned.
; Also calls FMT^ORPRF, which sets ^TMP("ORPRF" for Cat I flags
;
I '$L($TEXT(GETACT^DGPFAPI)) S ORY=0 Q
N FLAGID,PRFARR,CAT1CNT,ACTFLGS
K ^TMP("ORPRF",$J)
S ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR")
I 'ACTFLGS S ORY=0 Q
S (FLAGID,CAT1CNT)=0
F S FLAGID=$O(PRFARR(FLAGID)) Q:'FLAGID D
. I $P($G(PRFARR(FLAGID,"CATEGORY"))," ")="I" S CAT1CNT=CAT1CNT+1 Q
. K PRFARR(FLAGID)
I 'CAT1CNT S ORY=0 Q
D FMT(.@("PRFARR"))
S IDY=0 F S IDY=$O(^TMP("ORPRF",$J,IDY)) Q:'IDY D
. S ORY(IDY)=IDY_U_$G(^TMP("ORPRF",$J,IDY,"FLAG"))
S ORY=CAT1CNT
Q
;
HASCAT1(HASCAT1,PTDFN) ;Does patient have Category I flags (no arrays)
; Returns boolean HASCAT1 = 0 or 1
; Does NOT set arrays or TMP globals
N FLAGID,PRFARR,ACTFLGS
S (HASCAT1,FLAGID)=0
S ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR") I 'ACTFLGS G HASCAT1X
F S FLAGID=$O(PRFARR(FLAGID)) Q:'FLAGID D Q:HASCAT1
. I $P($G(PRFARR(FLAGID,"CATEGORY"))," ")="I" S HASCAT1=1
HASCAT1X ;
Q
;
TRIGRPOP(POPUP,PTDFN) ;Should the flag display pop up upon patient selection
; for patient PTDFN?
;As of 1/10/06, returns POPUP as:
; 1 if pt has any active flags, either Cat I or Cat II
; 0 otherwise
N PRFARR
S POPUP=$S($$GETACT^DGPFAPI(PTDFN,"PRFARR"):1,1:0)
Q
;
GETFLG(ORY,PTDFN,FLAGID) ;Return detailed flag info for flag FLAGID
I '$D(^TMP("ORPRF",$J,FLAGID)) Q
N IX,CNT
S (IX,CNT)=0
F S IX=$O(^TMP("ORPRF",$J,FLAGID,IX)) Q:'IX D
. S CNT=CNT+1,ORY(CNT)=$G(^TMP("ORPRF",$J,FLAGID,IX))
Q
;
CLEAR(ORY) ;Clear up the temp global
K ^TMP("ORPRF",$J)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORPRF 6444 printed Apr 09, 2024@21:45:04 Page 2
ORPRF ;SLC/JLI/JMC -Patient record flag ;6/14/06
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**173,187,190,215,243,472,542**;Dec 17, 1997;Build 11
+2 ;
FMT(ROOT,DBRSDATA,DGHIST) ; Format - Convert record flag data to displayable data
+1 ; Sets ^TMP("ORPRF",$J,NN) with flag data for multiple flags
+2 ; DBRSDATA - local array with DBRS data
+3 ; DGHIST - local array with PRF history records
+4 NEW IDX,IX,CNT,CURFLAG
+5 SET (IDX,CNT)=0
+6 FOR
SET IDX=$ORDER(ROOT(IDX))
if 'IDX
QUIT
Begin DoDot:1
+7 SET ^TMP("ORPRF",$JOB,IDX,"FLAG")=$PIECE($GET(ROOT(IDX,"FLAG")),U,2)
+8 SET ^TMP("ORPRF",$JOB,IDX,"CATEGORY")=$PIECE($GET(ROOT(IDX,"CATEGORY")),U,2)
+9 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="Flag Name: "_$PIECE($GET(ROOT(IDX,"FLAG")),U,2)
+10 IF $DATA(ROOT(IDX,"NARR"))
Begin DoDot:2
+11 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)=" "
+12 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="Assignment Narrative: "
+13 SET IX=0
FOR
SET IX=$ORDER(ROOT(IDX,"NARR",IX))
if 'IX
QUIT
Begin DoDot:3
+14 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)=$GET(ROOT(IDX,"NARR",IX,0))
End DoDot:3
End DoDot:2
+15 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)=" "
+16 ; -- Assignment Details:
+17 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="Flag Type: "_$PIECE($GET(ROOT(IDX,"FLAGTYPE")),U,2)
+18 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="Flag Category: "_$PIECE($GET(ROOT(IDX,"CATEGORY")),U,2)
+19 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="Assignment Status: "_"Active"
+20 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="Initial Assigned Date: "_$PIECE($GET(ROOT(IDX,"ASSIGNDT")),U,2)
+21 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="Approved by: "_$PIECE($GET(ROOT(IDX,"APPRVBY")),U,2)
+22 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="Next Review Date: "_$PIECE($GET(ROOT(IDX,"REVIEWDT")),U,2)
+23 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="Owner Site: "_$PIECE($GET(ROOT(IDX,"OWNER")),U,2)
+24 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="Originating Site: "_$PIECE($GET(ROOT(IDX,"ORIGSITE")),U,2)
+25 ;DBRS data
+26 IF $ORDER(DBRSDATA("BEHAVIORAL",0))
IF $PIECE($GET(ROOT(IDX,"FLAG")),U,2)="BEHAVIORAL"
Begin DoDot:2
+27 NEW ORDBRSC,ORZDBRSD
+28 SET ORDBRSC=0
FOR
SET ORDBRSC=+$ORDER(DBRSDATA("BEHAVIORAL",ORDBRSC))
if ORDBRSC=0
QUIT
Begin DoDot:3
+29 SET ORZDBRSD=$GET(DBRSDATA("BEHAVIORAL",ORDBRSC))
+30 IF $PIECE(ORZDBRSD,U,1)']""
QUIT
+31 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="DBRS number: "_$PIECE(ORZDBRSD,U,1)
+32 IF $PIECE(ORZDBRSD,U,2)]""
SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="Other DBRS data: "_$PIECE(ORZDBRSD,U,2)
End DoDot:3
End DoDot:2
+33 ;check if any history for the PRF flag that is being processed now
+34 SET CURFLAG=$PIECE($GET(ROOT(IDX,"FLAG")),U,2)
+35 IF $ORDER(DGHIST(CURFLAG,0))
Begin DoDot:2
+36 NEW ORPRFHCN,ORPRFHDA,ORPRFSIT,ORQUIT
+37 SET ORPRFSIT=""
SET ORQUIT=0
+38 SET ORPRFHCN=0
FOR
SET ORPRFHCN=+$ORDER(DGHIST(CURFLAG,ORPRFHCN))
if ORPRFHCN=0!(ORQUIT=1)
QUIT
Begin DoDot:3
+39 IF $DATA(DGHIST(CURFLAG,ORPRFHCN))
IF ORPRFHCN>10
Begin DoDot:4
+40 SET ORQUIT=1
+41 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="*** Additional information is in VistA ***"
End DoDot:4
if ORQUIT=1
QUIT
+42 IF ORPRFHCN=1
SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)=""
+43 IF ORPRFHCN=1
SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="History of Actions Taken:"
+44 IF ORPRFHCN=1
SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="Date Action Site ID Site Name"
+45 IF ORPRFHCN=1
SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)="------------------------------------------------"
+46 SET ORPRFHDA=$GET(DGHIST(CURFLAG,ORPRFHCN))
if ORPRFHDA=""
QUIT
+47 ;I ORPRFSIT'=$P(ORPRFHDA,U) S ORPRFSIT=$P(ORPRFHDA,U) S CNT=CNT+1,^TMP("ORPRF",$J,IDX,CNT)=ORPRFSIT_" changes:"
+48 SET CNT=CNT+1
SET ^TMP("ORPRF",$JOB,IDX,CNT)=$PIECE($PIECE(ORPRFHDA,U,2),"@",1)_" "_$$LJ^XLFSTR($PIECE(ORPRFHDA,U,3),15)_" "_$$LJ^XLFSTR($PIECE(ORPRFHDA,U,4),8)_" "_$$LJ^XLFSTR($EXTRACT($PIECE(ORPRFHDA,U,1),1,20),30)
End DoDot:3
if ORQUIT=1
QUIT
End DoDot:2
End DoDot:1
+49 KILL ROOT
+50 QUIT
+51 ;
HASFLG(ORY,PTDFN) ;Does patient PTDFN has flags
+1 ; DBIA 3860: $$GETACT^DGPFAPI(PTDFN,.FLGDATA)
+2 ; Returns array ORY listing active assigned flags
+3 ; Array ORY has form:
+4 ; ORY(flagID) = flagID^flagname,CAT1
+5 ; where CAT1 is 1 if flag is cat 1, 0 if cat 2
+6 ; ORY = Num of items returned in array ORY = num of flags
+7 IF '$LENGTH($TEXT(GETACT^DGPFAPI))
SET ORY=0
QUIT
+8 NEW IDY,PRFARR,CAT1
+9 KILL ^TMP("ORPRF",$JOB)
+10 SET ORY=$$GETACT^DGPFAPI(PTDFN,"PRFARR")
+11 if 'ORY
QUIT
+12 ;
+13 NEW DBRSARR,PRFHIST
+14 ;ICR# 6874 - check if DG*5.3*951 installed and then call the API to get DBRS information
+15 IF $TEXT(GETDBRS^DGPFDBRS)'=""
IF $$GETDBRS^DGPFDBRS(PTDFN,.DBRSARR)
+16 ;get history records for active PRFs
+17 DO ACTPRFHS^ORPRFHST(PTDFN,.PRFHIST)
+18 ;
+19 ; Sets ^TMP("ORPRF"
DO FMT(.@("PRFARR"),.DBRSARR,.PRFHIST)
+20 SET IDY=0
FOR
SET IDY=$ORDER(^TMP("ORPRF",$JOB,IDY))
if 'IDY
QUIT
Begin DoDot:1
+21 SET ORY(IDY)=IDY_U_$GET(^TMP("ORPRF",$JOB,IDY,"FLAG"))
+22 SET CAT1=0
+23 IF $GET(^TMP("ORPRF",$JOB,IDY,"CATEGORY"))="I (NATIONAL)"
SET CAT1=1
+24 SET ORY(IDY)=ORY(IDY)_U_CAT1
End DoDot:1
+25 QUIT
+26 ;
HASFLG1(ORY,PTDFN) ; Does patient PTDFN have **Cat I** flags
+1 ; Returns array ORY listing active assigned Cat I flags
+2 ; Array ORY has form:
+3 ; ORY(flagID) = flagID^flagname
+4 ; ORY = Num of Cat I flags
+5 ; If pt has no Cat I flags ORY = 0 and no flags are returned.
+6 ; Also calls FMT^ORPRF, which sets ^TMP("ORPRF" for Cat I flags
+7 ;
+8 IF '$LENGTH($TEXT(GETACT^DGPFAPI))
SET ORY=0
QUIT
+9 NEW FLAGID,PRFARR,CAT1CNT,ACTFLGS
+10 KILL ^TMP("ORPRF",$JOB)
+11 SET ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR")
+12 IF 'ACTFLGS
SET ORY=0
QUIT
+13 SET (FLAGID,CAT1CNT)=0
+14 FOR
SET FLAGID=$ORDER(PRFARR(FLAGID))
if 'FLAGID
QUIT
Begin DoDot:1
+15 IF $PIECE($GET(PRFARR(FLAGID,"CATEGORY"))," ")="I"
SET CAT1CNT=CAT1CNT+1
QUIT
+16 KILL PRFARR(FLAGID)
End DoDot:1
+17 IF 'CAT1CNT
SET ORY=0
QUIT
+18 DO FMT(.@("PRFARR"))
+19 SET IDY=0
FOR
SET IDY=$ORDER(^TMP("ORPRF",$JOB,IDY))
if 'IDY
QUIT
Begin DoDot:1
+20 SET ORY(IDY)=IDY_U_$GET(^TMP("ORPRF",$JOB,IDY,"FLAG"))
End DoDot:1
+21 SET ORY=CAT1CNT
+22 QUIT
+23 ;
HASCAT1(HASCAT1,PTDFN) ;Does patient have Category I flags (no arrays)
+1 ; Returns boolean HASCAT1 = 0 or 1
+2 ; Does NOT set arrays or TMP globals
+3 NEW FLAGID,PRFARR,ACTFLGS
+4 SET (HASCAT1,FLAGID)=0
+5 SET ACTFLGS=$$GETACT^DGPFAPI(PTDFN,"PRFARR")
IF 'ACTFLGS
GOTO HASCAT1X
+6 FOR
SET FLAGID=$ORDER(PRFARR(FLAGID))
if 'FLAGID
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(PRFARR(FLAGID,"CATEGORY"))," ")="I"
SET HASCAT1=1
End DoDot:1
if HASCAT1
QUIT
HASCAT1X ;
+1 QUIT
+2 ;
TRIGRPOP(POPUP,PTDFN) ;Should the flag display pop up upon patient selection
+1 ; for patient PTDFN?
+2 ;As of 1/10/06, returns POPUP as:
+3 ; 1 if pt has any active flags, either Cat I or Cat II
+4 ; 0 otherwise
+5 NEW PRFARR
+6 SET POPUP=$SELECT($$GETACT^DGPFAPI(PTDFN,"PRFARR"):1,1:0)
+7 QUIT
+8 ;
GETFLG(ORY,PTDFN,FLAGID) ;Return detailed flag info for flag FLAGID
+1 IF '$DATA(^TMP("ORPRF",$JOB,FLAGID))
QUIT
+2 NEW IX,CNT
+3 SET (IX,CNT)=0
+4 FOR
SET IX=$ORDER(^TMP("ORPRF",$JOB,FLAGID,IX))
if 'IX
QUIT
Begin DoDot:1
+5 SET CNT=CNT+1
SET ORY(CNT)=$GET(^TMP("ORPRF",$JOB,FLAGID,IX))
End DoDot:1
+6 QUIT
+7 ;
CLEAR(ORY) ;Clear up the temp global
+1 KILL ^TMP("ORPRF",$JOB)
+2 QUIT
+3 ;
