DGPFLF6 ;ALB/RPM - PRF FLAG MANAGEMENT LM SUB-ROUTINE ; 4/19/04 4:25pm
;;5.3;Registration;**425,554**;Aug 23, 1993
;
Q
;
PRININV(DGFIEN,DGPFLF) ;Prompt for principle investigators
;
; Input:
; DGFIEN - (optional) Pointer to PRF LOCAL FLAG (#26.11) file.
; [default=0]
; DGPFLF - Flag data array
;
; Output:
; Function Value - 1 on success, 0 when user enters "^"
; DGPFLF("PRININV") - Array of principal investigators
;
N DGASK ;answer from prompt as a pointer to NEW PERSON (#200) file
N DGCNT ;place holder for new entries
N DGDA ;default answer for prompt
N DGLAST ;last entry in field entry array
N DGLKUP ;principle investigator dynamic "B" index
N DGNEWPI ;principal investigator in FM external form
N DGORIG ;principle investigator unmodified "B" index
N DGPREV ;next to last entry in field entry array
N DGQUIT ;loop termination flag
N DGRSLT ;function value
;
S DGFIEN=+$G(DGFIEN) ;will be zero for 'Add Flag'
;
;build lookup and "on-file" array
M DGORIG=^DGPF(26.11,DGFIEN,2,"B")
M DGLKUP=DGORIG
;
S DGRSLT=1
S DGQUIT=0
S (DGLAST,DGCNT)=+$O(DGPFLF("PRININV",""),-1)
;
;set default answer
S DGDA=$P($G(DGPFLF("PRININV",DGLAST,0)),U,2)
;
F D Q:DGQUIT
. S DGASK=$$ANSWER^DGPFUT("Enter the Principal Investigator(s)",DGDA,"26.112,.01")
. ;
. ;stop prompting if user enters "^" or times out
. I DGASK=-1 S DGQUIT=1,DGRSLT=0 Q
. ;
. ;stop prompting if user accepts default entry
. I DGASK=$P($G(DGPFLF("PRININV",DGLAST,0)),U,1)!(DGASK="") S DGQUIT=1 Q
. ;
. ;perform lookup - re-prompt with new selection when entry exists
. I $D(DGLKUP(DGASK)) D Q
. . S DGLAST=+$O(DGLKUP(DGASK,0))
. . S DGDA=$P(DGPFLF("PRININV",DGLAST,0),U,2)
. ;
. ;process delete - remove entry from lookup array and move last pointer
. ; to previous entry in list. Set the field entry
. ; array value to "@" when the entry is "on-file",
. ; otherwise, remove the field entry array node.
. I DGASK="@" D Q
. . Q:'$D(DGPFLF("PRININV",DGLAST,0))
. . Q:'$$ANSWER^DGPFUT("Sure you want to delete '"_$P(DGPFLF("PRININV",DGLAST,0),U,2)_"' as a PRINCIPAL INVESTIGATOR","Yes","Y")
. . K DGLKUP($P(DGPFLF("PRININV",DGLAST,0),U,1))
. . S DGPREV=+$O(DGPFLF("PRININV",DGLAST),-1)
. . I $D(DGORIG($P(DGPFLF("PRININV",DGLAST,0),U,1))) D
. . . S DGPFLF("PRININV",DGLAST,0)="@"
. . E D
. . . K DGPFLF("PRININV",DGLAST,0)
. . S DGLAST=DGPREV
. . S DGDA=$P($G(DGPFLF("PRININV",DGLAST,0)),U,2)
. ;
. ;process new entry - if we make it here, then the entry is not the
. ; default, does not already exist in the field
. ; entry array and is not a delete. Add entry
. ; to the lookup array and the field entry array.
. I DGDA=""!(DGASK'=$P($G(DGPFLF("PRININV",DGLAST,0)),U)) D
. . S DGNEWPI=$$EXTERNAL^DILFD(26.112,.01,"F",DGASK)
. . Q:'$$ANSWER^DGPFUT("Are you adding '"_DGNEWPI_"' as a new PRINCIPAL INVESTIGATOR","No","Y")
. . S DGCNT=DGCNT+1
. . S DGLKUP(DGASK,DGCNT)=""
. . S DGPFLF("PRININV",DGCNT,0)=DGASK_U_DGNEWPI
. . S DGDA=""
;
Q DGRSLT
;
ASGNCNT(DGFIEN,DGDFNLST) ;counts existing assignments for a given flag
;This function searches for assignments for a given flag IEN and
;returns the count of assignments. An optional array parameter will
;be loaded with the DFNs assigned to the flag.
;
; Input:
; DGFIEN - (required) Pointer to PRF LOCAL FLAG (#26.11) file or
; PRF NATIONAL FLAG (#26.15) file.
; DGDFNLST - (optional) Array name to contain list of DFNs
;
; Output:
; Function Value - count of existing assignments
; DGDFNLST - Defined only when existing assignments are found.
; Array of DFNs from existing assignments.
; Example: DGDFNLST(7172421)=assignment IEN
;
N DGCNT ;function value
N DGDFN ;pointer to PATIENT (#2) file
;
S DGCNT=0
;
I $G(DGFIEN)]"",$D(^DGPF(26.13,"AFLAG",DGFIEN)) D
. ;
. ;count the assignments
. S DGDFN=0
. F S DGDFN=$O(^DGPF(26.13,"AFLAG",DGFIEN,DGDFN)) Q:'DGDFN D
. . S DGCNT=DGCNT+1
. . S DGDFNLST(DGDFN)=+$O(^DGPF(26.13,"AFLAG",DGFIEN,DGDFN,0))
;
Q DGCNT
;
;
CKTIUPN(DGTITLE,DGARRAY) ;check for progress notes linked to a record flag
;This function is used to check all assignment history records of
;patients that are assigned to a given Record Flag for any existing
;associated Progress Note ien values setup.
;
;If any associated Progress Notes are found, the given Record Flag's
;Progress Note Title should not be edited until all the assignment
;history records are un-linked from that given record flag.
;
; Input:
; DGTITLE - IEN pointer to the TIU DOCUMENT (#8925.1) file
; DGARRAY - Name of temp global closed root reference that
; contains the list of DFNs assigned to record flag
; i.e. ^TMP("DGPHTIU",564715668,7172421)=assignment IEN of (#26.13)
;
; Output:
; Function result - "1" = if any linked Progress Notes are found
; - "0" = if none found
;
N DGRSLT ;function output - 0 or 1
N DGDFN ;pointer to PATIENT (#2) file
N DGHTIU ;array of return values for each assignment history record
N DGI ;for loop var
;
S DGRSLT=0
;
I $G(DGTITLE),$G(DGARRAY)]"" D
. ;
. S DGHTIU=$NA(^TMP("DGHTIU",$J))
. S DGDFN=0
. F S DGDFN=$O(@DGARRAY@(DGDFN)) Q:DGDFN="" D Q:DGRSLT
. . K @DGHTIU
. . I $$GETHTIU^DGPFAPI1(DGDFN,DGTITLE,DGHTIU) D
. . . S DGI=""
. . . F S DGI=$O(@DGHTIU@("HISTORY",DGI)) Q:DGI="" D Q:DGRSLT
. . . . I $P($G(@DGHTIU@("HISTORY",DGI,"TIUIEN")),U)]"" S DGRSLT=1
. ;
. K @DGHTIU
;
Q DGRSLT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFLF6 5808 printed Apr 09, 2024@21:59:37 Page 2
DGPFLF6 ;ALB/RPM - PRF FLAG MANAGEMENT LM SUB-ROUTINE ; 4/19/04 4:25pm
+1 ;;5.3;Registration;**425,554**;Aug 23, 1993
+2 ;
+3 QUIT
+4 ;
PRININV(DGFIEN,DGPFLF) ;Prompt for principle investigators
+1 ;
+2 ; Input:
+3 ; DGFIEN - (optional) Pointer to PRF LOCAL FLAG (#26.11) file.
+4 ; [default=0]
+5 ; DGPFLF - Flag data array
+6 ;
+7 ; Output:
+8 ; Function Value - 1 on success, 0 when user enters "^"
+9 ; DGPFLF("PRININV") - Array of principal investigators
+10 ;
+11 ;answer from prompt as a pointer to NEW PERSON (#200) file
NEW DGASK
+12 ;place holder for new entries
NEW DGCNT
+13 ;default answer for prompt
NEW DGDA
+14 ;last entry in field entry array
NEW DGLAST
+15 ;principle investigator dynamic "B" index
NEW DGLKUP
+16 ;principal investigator in FM external form
NEW DGNEWPI
+17 ;principle investigator unmodified "B" index
NEW DGORIG
+18 ;next to last entry in field entry array
NEW DGPREV
+19 ;loop termination flag
NEW DGQUIT
+20 ;function value
NEW DGRSLT
+21 ;
+22 ;will be zero for 'Add Flag'
SET DGFIEN=+$GET(DGFIEN)
+23 ;
+24 ;build lookup and "on-file" array
+25 MERGE DGORIG=^DGPF(26.11,DGFIEN,2,"B")
+26 MERGE DGLKUP=DGORIG
+27 ;
+28 SET DGRSLT=1
+29 SET DGQUIT=0
+30 SET (DGLAST,DGCNT)=+$ORDER(DGPFLF("PRININV",""),-1)
+31 ;
+32 ;set default answer
+33 SET DGDA=$PIECE($GET(DGPFLF("PRININV",DGLAST,0)),U,2)
+34 ;
+35 FOR
Begin DoDot:1
+36 SET DGASK=$$ANSWER^DGPFUT("Enter the Principal Investigator(s)",DGDA,"26.112,.01")
+37 ;
+38 ;stop prompting if user enters "^" or times out
+39 IF DGASK=-1
SET DGQUIT=1
SET DGRSLT=0
QUIT
+40 ;
+41 ;stop prompting if user accepts default entry
+42 IF DGASK=$PIECE($GET(DGPFLF("PRININV",DGLAST,0)),U,1)!(DGASK="")
SET DGQUIT=1
QUIT
+43 ;
+44 ;perform lookup - re-prompt with new selection when entry exists
+45 IF $DATA(DGLKUP(DGASK))
Begin DoDot:2
+46 SET DGLAST=+$ORDER(DGLKUP(DGASK,0))
+47 SET DGDA=$PIECE(DGPFLF("PRININV",DGLAST,0),U,2)
End DoDot:2
QUIT
+48 ;
+49 ;process delete - remove entry from lookup array and move last pointer
+50 ; to previous entry in list. Set the field entry
+51 ; array value to "@" when the entry is "on-file",
+52 ; otherwise, remove the field entry array node.
+53 IF DGASK="@"
Begin DoDot:2
+54 if '$DATA(DGPFLF("PRININV",DGLAST,0))
QUIT
+55 if '$$ANSWER^DGPFUT("Sure you want to delete '"_$PIECE(DGPFLF("PRININV",DGLAST,0),U,2)_"' as a PRINCIPAL INVESTIGATOR","Yes","Y")
QUIT
+56 KILL DGLKUP($PIECE(DGPFLF("PRININV",DGLAST,0),U,1))
+57 SET DGPREV=+$ORDER(DGPFLF("PRININV",DGLAST),-1)
+58 IF $DATA(DGORIG($PIECE(DGPFLF("PRININV",DGLAST,0),U,1)))
Begin DoDot:3
+59 SET DGPFLF("PRININV",DGLAST,0)="@"
End DoDot:3
+60 IF '$TEST
Begin DoDot:3
+61 KILL DGPFLF("PRININV",DGLAST,0)
End DoDot:3
+62 SET DGLAST=DGPREV
+63 SET DGDA=$PIECE($GET(DGPFLF("PRININV",DGLAST,0)),U,2)
End DoDot:2
QUIT
+64 ;
+65 ;process new entry - if we make it here, then the entry is not the
+66 ; default, does not already exist in the field
+67 ; entry array and is not a delete. Add entry
+68 ; to the lookup array and the field entry array.
+69 IF DGDA=""!(DGASK'=$PIECE($GET(DGPFLF("PRININV",DGLAST,0)),U))
Begin DoDot:2
+70 SET DGNEWPI=$$EXTERNAL^DILFD(26.112,.01,"F",DGASK)
+71 if '$$ANSWER^DGPFUT("Are you adding '"_DGNEWPI_"' as a new PRINCIPAL INVESTIGATOR","No","Y")
QUIT
+72 SET DGCNT=DGCNT+1
+73 SET DGLKUP(DGASK,DGCNT)=""
+74 SET DGPFLF("PRININV",DGCNT,0)=DGASK_U_DGNEWPI
+75 SET DGDA=""
End DoDot:2
End DoDot:1
if DGQUIT
QUIT
+76 ;
+77 QUIT DGRSLT
+78 ;
ASGNCNT(DGFIEN,DGDFNLST) ;counts existing assignments for a given flag
+1 ;This function searches for assignments for a given flag IEN and
+2 ;returns the count of assignments. An optional array parameter will
+3 ;be loaded with the DFNs assigned to the flag.
+4 ;
+5 ; Input:
+6 ; DGFIEN - (required) Pointer to PRF LOCAL FLAG (#26.11) file or
+7 ; PRF NATIONAL FLAG (#26.15) file.
+8 ; DGDFNLST - (optional) Array name to contain list of DFNs
+9 ;
+10 ; Output:
+11 ; Function Value - count of existing assignments
+12 ; DGDFNLST - Defined only when existing assignments are found.
+13 ; Array of DFNs from existing assignments.
+14 ; Example: DGDFNLST(7172421)=assignment IEN
+15 ;
+16 ;function value
NEW DGCNT
+17 ;pointer to PATIENT (#2) file
NEW DGDFN
+18 ;
+19 SET DGCNT=0
+20 ;
+21 IF $GET(DGFIEN)]""
IF $DATA(^DGPF(26.13,"AFLAG",DGFIEN))
Begin DoDot:1
+22 ;
+23 ;count the assignments
+24 SET DGDFN=0
+25 FOR
SET DGDFN=$ORDER(^DGPF(26.13,"AFLAG",DGFIEN,DGDFN))
if 'DGDFN
QUIT
Begin DoDot:2
+26 SET DGCNT=DGCNT+1
+27 SET DGDFNLST(DGDFN)=+$ORDER(^DGPF(26.13,"AFLAG",DGFIEN,DGDFN,0))
End DoDot:2
End DoDot:1
+28 ;
+29 QUIT DGCNT
+30 ;
+31 ;
CKTIUPN(DGTITLE,DGARRAY) ;check for progress notes linked to a record flag
+1 ;This function is used to check all assignment history records of
+2 ;patients that are assigned to a given Record Flag for any existing
+3 ;associated Progress Note ien values setup.
+4 ;
+5 ;If any associated Progress Notes are found, the given Record Flag's
+6 ;Progress Note Title should not be edited until all the assignment
+7 ;history records are un-linked from that given record flag.
+8 ;
+9 ; Input:
+10 ; DGTITLE - IEN pointer to the TIU DOCUMENT (#8925.1) file
+11 ; DGARRAY - Name of temp global closed root reference that
+12 ; contains the list of DFNs assigned to record flag
+13 ; i.e. ^TMP("DGPHTIU",564715668,7172421)=assignment IEN of (#26.13)
+14 ;
+15 ; Output:
+16 ; Function result - "1" = if any linked Progress Notes are found
+17 ; - "0" = if none found
+18 ;
+19 ;function output - 0 or 1
NEW DGRSLT
+20 ;pointer to PATIENT (#2) file
NEW DGDFN
+21 ;array of return values for each assignment history record
NEW DGHTIU
+22 ;for loop var
NEW DGI
+23 ;
+24 SET DGRSLT=0
+25 ;
+26 IF $GET(DGTITLE)
IF $GET(DGARRAY)]""
Begin DoDot:1
+27 ;
+28 SET DGHTIU=$NAME(^TMP("DGHTIU",$JOB))
+29 SET DGDFN=0
+30 FOR
SET DGDFN=$ORDER(@DGARRAY@(DGDFN))
if DGDFN=""
QUIT
Begin DoDot:2
+31 KILL @DGHTIU
+32 IF $$GETHTIU^DGPFAPI1(DGDFN,DGTITLE,DGHTIU)
Begin DoDot:3
+33 SET DGI=""
+34 FOR
SET DGI=$ORDER(@DGHTIU@("HISTORY",DGI))
if DGI=""
QUIT
Begin DoDot:4
+35 IF $PIECE($GET(@DGHTIU@("HISTORY",DGI,"TIUIEN")),U)]""
SET DGRSLT=1
End DoDot:4
if DGRSLT
QUIT
End DoDot:3
End DoDot:2
if DGRSLT
QUIT
+36 ;
+37 KILL @DGHTIU
End DoDot:1
+38 ;
+39 QUIT DGRSLT
