DGPFUT61 ;SHRPE/SGM - DBRS# EDIT UTILS ; Jan 19, 2018 16:45
;;5.3;Registration;**951**;Aug 13, 1993;Build 135
; Last Edited: SHRPE/sgm - Nov 7, 2018 09:26
;
; This routine is only invoked via routine DGPFUT6
;
; ICR# TYPE DESCRIPTION
;----- ---- -----------------------------------------
; 2050 Sup MSG^DIALOG
; 2053 Sup ^DIE: CHK, $$FILE, $$UPDATE
; 2171 Sup $$NS^XUAF4
;10006 Sup ^DIC
;10013 Sup ^DIK
;10018 Sup ^DIE
;10103 Sup $$NOW^XLFDT
;10112 Sup $$SITE^VASITE
;
Q
;=====================================================================
; $$GETASGN^DGPFA initializes DGPFA()
; Use ^DIC to select DBRS record, may add a new record
; Use ^DIR to edit .01 and/or .02 fields
; When editing done, put file 26.13 entry back to state before edit
; Set up DPGFA() and DGPFAH(). See ^DGPFAA for array formats
;
DBRS() ; called from DGPFLMA3, action = 3,4,5,6
;EXTRINSIC FUNCTION: 1:allow DGPFLMA3 to continue
; 0:DGPFLMA3 is to exit and return to LM screen
;
; Expected local variables from DGPFLMA3:
; DGPFA(), DGPFAH(), DGIEN
;
N I,J,X,Y,ACT,CHG,DBRS,NM,OUT
;----- only select actions to be prompted for DBRS enter/edit
S ACT=+DGPFAH("ACTION") I "^2^3^4^6^"'[(U_ACT_U) Q 1
S OUT=1
;
;----- initially set up the PRE and POST arrays to be the same
D GET(.DBRS,"PRE",DGIEN)
M DBRS("POST")=DBRS("PRE")
;----- inactivate action does not edit dbrs data
I ACT=3 D EDTINACT Q 1
;
D EDIT I OUT=-2 Q 0
;------ If no changes what action should LM take?
; If action="X", exit to LM menu
; If no data changes, no change to DGPFA(), setup DGPFAH()
I '$$EDITCHG Q $S(ACT=6:0,1:1)
;------ Set DGPFA() to be what it will look like if accept changes
D EDITPFA
;------ Build DBRS(0) which sorts data by DBRS#
; DBRS(0,dbrs#,1,field#) = pre-image value
; DBRS(0,dbrs#,2,field#) = post-image value
D EDITSORT
;------ Build DGPFAH()
D EDITPFAH
Q 1
;
;=====================================================================
DBRSVAL(DGN,DGNIEN) ; validate DBRS#, check for uniqueness
; INPUT PARAMETERS:
; DGN - required - DBRS Number
; DGNIEN - optional - <26.131_ien>,<26.13_ien>
; if passed, 26.13_ien is required
; 26.131_ien can be "", n, or +n
; 26.13_ien required if passed
; if adding a new DBRS, 26.131_ien=""
; EXTRINSIC FUNCTION returns: p1^p2^p3 where
; p1 = -1:failed 0:passed with conditions 1:DBRS# unique
; p2 = message
; -1^message = failure
; 0^message = DGN passed, DGN assigned, but cannot determine
; if DGNIEN and that assignment are the same or
; that the DBRS internal record number match
; 0^iens = DGN passed, 26.13 values match, cannot determine
; if DBRS record number match. If DBRS#
; registered then iens=26.131ien,26.13ien
; 1[^iens] = DGN passes all business rules
; if appropriate pass back the existing IENS for
; that DBRS#
;
N X,Y,ANS,ASGN,DA,DGA,DGERR,DIERR,DGRET,IEN,MSG
S MSG(1)="DBRS# not of the proper format"
S MSG(2)="Invalid IENS value received"
S MSG(3)="This DBRS# is already assigned to another assignment: #"
S MSG(4)="This DBRS# already assigned to this flag assignment"
S MSG(5)="Assignment IEN received does not exist: "
S DGNIEN=$G(DGNIEN) S:DGNIEN="" DGNIEN=",,"
I $L(DGNIEN,",")'=3 S ANS="-1^2" G DVOUT
;
; check format of DBRS#
I '$L($G(DGN)) S ANS="-1^1" G DVOUT
;
D CHK^DIE(26.131,.01,,DGN,.DGRET,"DGERR") K DA
I $D(DIERR)!(DGRET=U) S ANS="-1^1" G DVOUT
;
; check for uniqueness of DBRS#
; DA has existing IEN values for DBRS#
; DGA has iens from input DGNIEN
S (DA,DA(1))=0
S Y=$O(^DGPF(26.13,"DBRS",DGN,0)) I Y D
. S DA(1)=Y,DA=$O(^DGPF(26.13,"DBRS",DGN,DA(1),0))
. Q
S DGA=$P(DGNIEN,",")
S DGA(1)=$P(DGNIEN,",",2)
; dbrs# is not already assigned
I 'DA(1) S ANS=1 G DVOUT
; dbrs# is assigned to some assignment
; iens is adding a new assignment or looking for one
I $E(DGA(1))="+" S ANS="-1^3^"_DA(1) G DVOUT
I $E(DGA(1))="?" S ANS="0^3^"_DA(1) G DVOUT
; validate assignment ien passed in
I +DGA(1)=0 S ANS="0^3^"_DA(1) G DVOUT
I +DGA(1),'$D(^DGPF(26.13,DGA(1),0)) S ANS="-1^5"_DGA(1) G DVOUT
I DGA(1)'=DA(1) S ANS="-1^3^"_DA(1) G DVOUT
; evaluate if trying to add DBRS a second time to an assignment
I 'DA S ANS=1 G DVOUT
I $E(DGA)="+" S ANS="-1^4" G DVOUT
I $E(DGA)="?" S ANS="0^4" G DVOUT
I +DGA=0 S ANS="0^4" G DVOUT
I DGA'=DA S ANS="-1^4" G DVOUT
S ANS=1
DVOUT ;
S X=$P(ANS,U),Y=$P(ANS,U,2) S:Y X=X_U_MSG(Y)_$P(ANS,U,3)
Q X
;
;=====================================================================
EIE(DGPFH) ; Message about EIE and deleting DBRS data
; INPUT: .DGPFH = .DGPFAH, see GETHIST^DGPFAAH for array description
Q:'$D(DGPFH("DBRS"))
N I,X,Y,DGT,INC,JINC,NM,SP,TXT
D TEXT(.TXT,7,1)
F I=1:1:3 S DGT("DIMSG",I)=TXT(I)
S $P(SP," ",21)=""
S INC=3
S (X,NM)="" F JINC=0:0 S JINC=$O(DGPFH("DBRS",JINC)) Q:'JINC D
. S Y=DGPFH("DBRS",JINC),NM=$P(Y,U) Q:$P(Y,U,4)'="D"
. S X=X_$E(NM_SP,1,20) I $L(X)>60 S INC=INC+1,DGT("DIMSG",INC)=X,X=""
. Q
I $L(X) S INC=INC+1,DGT("DIMSG",INC)=X
S INC=INC+1,DGT("DIMAG",INC)=" "
F J=4,5 S INC=INC+1,DGT("DIMSG",INC)=TXT(J)
S INC=INC+1,DGT("DIMSG",INC)=" "
D MSG^DIALOG("MW",,,,"DGT")
Q
;
;=====================================================================
; PRIVATE SUBROUTINES
;=====================================================================
ADD(DGIEN,DGDATA,DEL) ;
; INPUT PARAMETERS
; DGIEN - required - file 26.13 ien
; DEL - optional - 1:delete any existing dbrs#
; .DGDATA - optional - DBRS# to be added, do not add dups
; DGDATA(dbrs#) = iens for dbrs multiple
; first ien may be a number or +inc
; DGDATA(dbrs#,field#) = internal value
;
N I,J,X,Y,DGERR,DGEXIST,DGFDA,DIERR,INC,NM
Q:$G(DGIEN)<1 Q:$E(DGIEN)="+"
Q:'$D(^DGPF(26.13,+DGIEN,0))
D GETDBRS^DGPFUT6(.DGEXIST,+DGIEN) ; get any existing iens
I +$G(DEL) D DEL^DGPFUT6(+DGIEN,26.13) K DGEXIST
I '$D(DGDATA) Q
S INC=0
S NM=0 F I=0:0 S NM=$O(DGDATA(NM)) Q:NM="" D
. N IENS
. I $D(DGEXIST(NM)) Q
. S INC=INC+1
. S IENS="+"_INC_","_(+DGIEN)_","
. S DGFDA(26.131,IENS,.01)=NM
. S X=$P($G(DGDATA(NM,.02)),U)
. I $L(X),X'="<no value>" S DGFDA(26.131,IENS,.02)=X
. S X=$P($G(DGDATA(NM,.03)),U) I +X S DGFDA(26.131,IENS,.03)=X
. S X=$P($G(DGDATA(NM,.04)),U) I +X S DGFDA(26.131,IENS,.04)=X
. Q
I $D(DGFDA) D UPDATE^DIE(,"DGFDA","DGERR")
Q
;
; =============== FM ENTER/EDIT DBRS DATA ===============
EDIT ;
; Only certain actions allowed to edit DBRS#
; FOR loop allows for editing more than one DBRS#
; DBRS() reset if appropriate in each iteration through FOR loop
;
N DGPRE
D EH
F D Q:OUT<0
. ; DATA := value of DBRS record data after DIC selection
. ; DATA(1) = after ^DIC, .01^.02^.03^.04^dbrs#_iens^new_flag
. ; DATA(2) = after ^DIR, .01^.02^.03^.04
. ; OUT := controller of FOR loop and ListManager action
. ; -2 := time_out, exit to Listmanager, make no changes
. ; -1 := finish editing, continue processing
. ; 1 := one DBRS# edit session completely successfully
. ;
. ;----- select or add a new DBRS record
. N X,Y,DGDIC,DGDIE,NM
. S OUT=1
. D I OUT<0 Q
. . N X,DA,DIC,DLAYGO,DTOUT,DUOUT,TMP
. . S DA(1)=DGIEN
. . S DIC=$NA(^DGPF(26.13,+DGIEN,2)),DIC=$TR(DIC,")",",")
. . S DIC(0)="QAELMZn",DLAYGO=26.131
. . S DIC("DR")=".02""DBRS Other"""
. . W ! D ^DIC I $D(DTOUT) S OUT=-2 Q
. . I $D(DUOUT)!(Y<1) S OUT=-1 Q
. . ; TMP = .01^.02^.03^.04^iens^new_flag
. . S TMP=Y(0),$P(TMP,U,5)=(+Y)_","_DGIEN_","_U_$P(Y,U,3)
. . ; is new record a duplicate?
. . I +$P(TMP,U,6),$D(DBRS("POST",$P(TMP,U))) D S OUT=0
. . . S OUT=0 W ! D TEXT(,1) W !
. . . N Y,DA,DIK
. . . S Y=$P(TMP,U,5),DA=+Y,DA(1)=+$P(Y,",",2),DIK=DIC D ^DIK
. . . Q
. . S DGDIC=TMP
. . Q
. ;
. I '$D(DGDIC) S OUT=-1 Q
. S DGDIE=$P(DGDIC,U,1,4)
. ;
. ;----- if existing record selected, allow editing of .01 field
. I '$P(DGDIC,U,6),DGDIE'="@" D I OUT<1 Q
. . N A,X,Y,DR,DIE,DR,DTOUT,DUOUT,PRE
. . S A=$P(DGDIC,U,5),DA=+A,DA(1)=+$P(A,",",2)
. . S PRE=^DGPF(26.13,DA(1),2,DA,0)
. . S DIE=$NA(^DGPF(26.13,+DGIEN,2)),DIE=$TR(DIE,")",",")
. . S DR=".01;.02"
. . W ! D ^DIE
. . I $D(DTOUT) S OUT=-2 Q
. . S A=$P(DGDIC,U,5),DA=+A,DA(1)=+$P(A,",",2)
. . S X=$G(^DGPF(26.13,DA(1),2,DA,0))
. . I X="" S DGDIE="@" Q
. . E S DGDIE=X
. . I $P(X,U)=$P(PRE,U) Q
. . I '$D(DBRS("POST",$P(X,U))) Q
. . W ! D TEXT(,3) W ! S OUT=0
. . S DR=".01///"_$P(PRE,U)_";.02///"_$P(PRE,U,2) D ^DIE
. . Q
. ;
. ;----- now make changes to DBRS()
. S NM=$P(DGDIC,U)
. S NM(1)=$P(DGDIE,U)
. ; new record added
. I +$P(DGDIC,U,6) D Q
. . S DBRS("POST",NM)=$P(DGDIC,U,5)
. . S DBRS("POST",NM,.01)=$P(DGDIC,U,1)
. . S DBRS("POST",NM,.02)=$P(DGDIC,U,2)
. . S DBRS("POST",NM,.03)=$P(DGDIC,U,3)
. . S DBRS("POST",NM,.04)=$P(DGDIC,U,4)
. . Q
. ; existing record to be deleted
. I NM(1)="@" K DBRS("POST",NM) Q
. ; existing record .01 field value changed
. I NM'=NM(1) D Q
. . K DBRS("POST",NM)
. . S DBRS("POST",NM(1))=$P(DGDIC,U,5)
. . S DBRS("POST",NM(1),.01)=$P(DGDIE,U,1)
. . S DBRS("POST",NM(1),.02)=$P(DGDIE,U,2)
. . S DBRS("POST",NM(1),.03)=$P(DGDIE,U,3)
. . S DBRS("POST",NM(1),.04)=$P(DGDIE,U,4)
. . Q
. ; dbrs# unchanged, OTHER may or may not have changed
. S DBRS("POST",NM(1),.02)=$P(DGDIE,U,2)
. Q
; Reset 26.13 file DBRS data to pre-edit state
M DGPRE=DBRS("PRE") D ADD(DGIEN,.DGPRE,1)
Q
;
EDITCHG() ;----- check to see if any data changed at all
N J,X,CHG,INC,NM
S CHG=0
S NM=0 F J=0:0 S NM=$O(DBRS("PRE",NM)) Q:NM="" D Q:CHG
. I DBRS("PRE",NM,.01)'=$G(DBRS("POST",NM,.01)) S CHG=1
. I DBRS("PRE",NM,.02)'=$G(DBRS("POST",NM,.02)) S CHG=1
. Q
I 'CHG S NM=0 F J=0:0 S NM=$O(DBRS("POST",NM)) Q:NM="" D Q:CHG
. I DBRS("POST",NM,.01)'=$G(DBRS("PRE",NM,.01)) S CHG=1
. I DBRS("POST",NM,.02)'=$G(DBRS("PRE",NM,.02)) S CHG=1
. Q
I 'CHG D EDTINACT
Q CHG
;
EDTINACT ; set up DGPFAH() if no change
N J,X,INC,NM
S INC=0
S NM=0 F J=0:0 S NM=$O(DBRS("PRE",NM)) Q:NM="" D
. S X=DBRS("PRE",NM,.01)_U_DBRS("PRE",NM,.02)_U_DBRS("PRE",NM,.03)
. S X=X_U_"N"_U_DBRS("PRE",NM,.04)
. S INC=INC+1,DGPFAH("DBRS",INC)=X
. Q
Q
;
EDITPFA ;----- set DGPFA() to values if changes accepted
N J,X,NM
F X="DBRS#","DBRS OTHER","DBRS DATE","DBRS SITE" K DGPFA(X)
S (J,NM)=0 F J=0:0 S NM=$O(DBRS("POST",NM)) Q:NM="" D
. S J=J+1
. S DGPFA("DBRS#",J)=DBRS("POST",NM,.01)_U_$$EXT(NM,.01)
. S DGPFA("DBRS OTHER",J)=DBRS("POST",NM,.02)_U_$$EXT(NM,.02)
. S DGPFA("DBRS DATE",J)=DBRS("POST",NM,.03)_U_$$EXT(NM,.03)
. S DGPFA("DBRS SITE",J)=DBRS("POST",NM,.04)_U_$$EXT(NM,.04)
. Q
Q
;
EDITPFAH ;----- Create DGPFAH()
N I,J,X,Y,INC,NM
S (INC,NM)=0 F I=0:0 S NM=$O(DBRS(0,NM)) Q:NM="" D
. N PRE,POST
. S PRE="" I $D(DBRS(0,NM,1)) D
. . S $P(PRE,U,1)=$G(DBRS(0,NM,1,.01))
. . S $P(PRE,U,2)=$G(DBRS(0,NM,1,.02))
. . S $P(PRE,U,3)=$G(DBRS(0,NM,1,.03))
. . S $P(PRE,U,5)=$G(DBRS(0,NM,1,.04))
. . Q
. S POST="" I $D(DBRS(0,NM,2)) D
. . S $P(POST,U,1)=$G(DBRS(0,NM,2,.01))
. . S $P(POST,U,2)=$G(DBRS(0,NM,2,.02))
. . S $P(POST,U,3)=$G(DBRS(0,NM,2,.03))
. . S $P(POST,U,5)=$G(DBRS(0,NM,2,.04))
. . Q
. S INC=INC+1
. ;----- no changes to DBRS
. I PRE=POST S:PRE'="" $P(PRE,U,4)="N",DGPFAH("DBRS",INC)=PRE Q
. ;----- POST="", DBRS deleted
. I POST="" S $P(PRE,U,4)="D",DGPFAH("DBRS",INC)=PRE Q
. ;----- PRE="", DBRS added
. I PRE="" S $P(POST,U,4)="A",DGPFAH("DBRS",INC)=POST Q
. ;----- DBRS record edited
. ; If date/site exist, may not be changed
. S $P(POST,U,4)="E"
. S X=$P(PRE,U,3) I X>0,$P(POST,U,3)'=X S $P(POST,U,3)=X
. S X=$P(PRE,U,5) I X>0,$P(POST,U,5)'=X S $P(POST,U,5)=X
. S DGPFAH("DBRS",INC)=POST
. Q
Q
;
EDITSORT ;----- Sort the DBRS() by DBRS#
N I,NM
S NM=0
F I=0:0 S NM=$O(DBRS("PRE",NM)) Q:NM="" M DBRS(0,NM,1)=DBRS("PRE",NM)
S NM=0
F I=0:0 S NM=$O(DBRS("POST",NM)) Q:NM="" M DBRS(0,NM,2)=DBRS("POST",NM)
Q
;
EH ;
;;You may add, edit, or delete a DBRS entry for this assignment.
;;To delete an entry, use the '@' sign after '//'.
;;
N I,X,Y
W !
F I=1:1 S X=$P($T(EH+I),";;",2) Q:X="" W !,X
; S X=$$ANSWER^DGPFUT("Press any key to continue",,"E")
Q
;
EXT(DBS,FLD) ; get external value
; DBS = DBRS#
; FLD = field number
N X,Y
S Y="",X=$G(DBRS("POST",NM,FLD))
I FLD=.01 S Y=X
I FLD=.02 S Y=X S:X="" Y="<no value>"
I FLD=.03,X>0 S Y=$$FMTE^XLFDT(X,"5Z")
I FLD=.04,X>0 S Y=$P($$NS^XUAF4(X),U)
Q Y
;
GET(DBRS,NODE,IEN) ;
; get dbrs records from 26.13
; only return DBRS() with internal FM form of the data
; .DBRS - return array
; NODE = PRE or POST
; IEN = file 26.13 ien
N I,DGRET,NM
Q:$G(IEN)<1
D GETDBRS^DGPFUT6(.DGRET,IEN)
; see GETDBRS^DGPRUT62 for description of .DGRET
S DBRS(NODE)=0
S (I,NM)=0 F S NM=$O(DGRET(NM)) Q:NM="" D
. S DBRS(NODE)=1+$G(DBRS(NODE))
. S DBRS(NODE,NM)=DGRET(NM) ; iens
. S DBRS(NODE,NM,.01)=NM
. S DBRS(NODE,NM,.02)=$P(DGRET(NM,"OTHER"),U)
. S DBRS(NODE,NM,.03)=$P(DGRET(NM,"DATE"),U)
. S DBRS(NODE,NM,.04)=$P(DGRET(NM,"SITE"),U)
. Q
Q
;
NOW() N I,X,Y,Z Q $E($$NOW^XLFDT,1,12)
;
TEXT(TXT,ST,NOWR) ;
N I,J,X S J=0
F I=ST:1 S X=$P($T(T+I),";",3,9) Q:X="[end]" S J=J+1,TXT(J)=" "_X
I '$G(NOWR) F I=1:1 Q:'$D(TXT(I)) W !,TXT(I)
Q
T ;
;;This DBRS# Number is already associated with this assignment.
;;[end]
;;You have changed the name of an existing DBRS Number to be the same
;;as an existing DBRS entry for this flag assignment. This is not
;;allowed.
;;[end]
;;
;;You have marked this assignment as Entered In Error
;;All of the following DBRS Numbers will be removed from this assignment:
;;DO NOT file the assignment if you do not wish these DBRS Numbers
;;removed from this assignment.
;;[end]
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFUT61 14439 printed Sep 23, 2025@20:24:48 Page 2
DGPFUT61 ;SHRPE/SGM - DBRS# EDIT UTILS ; Jan 19, 2018 16:45
+1 ;;5.3;Registration;**951**;Aug 13, 1993;Build 135
+2 ; Last Edited: SHRPE/sgm - Nov 7, 2018 09:26
+3 ;
+4 ; This routine is only invoked via routine DGPFUT6
+5 ;
+6 ; ICR# TYPE DESCRIPTION
+7 ;----- ---- -----------------------------------------
+8 ; 2050 Sup MSG^DIALOG
+9 ; 2053 Sup ^DIE: CHK, $$FILE, $$UPDATE
+10 ; 2171 Sup $$NS^XUAF4
+11 ;10006 Sup ^DIC
+12 ;10013 Sup ^DIK
+13 ;10018 Sup ^DIE
+14 ;10103 Sup $$NOW^XLFDT
+15 ;10112 Sup $$SITE^VASITE
+16 ;
+17 QUIT
+18 ;=====================================================================
+19 ; $$GETASGN^DGPFA initializes DGPFA()
+20 ; Use ^DIC to select DBRS record, may add a new record
+21 ; Use ^DIR to edit .01 and/or .02 fields
+22 ; When editing done, put file 26.13 entry back to state before edit
+23 ; Set up DPGFA() and DGPFAH(). See ^DGPFAA for array formats
+24 ;
DBRS() ; called from DGPFLMA3, action = 3,4,5,6
+1 ;EXTRINSIC FUNCTION: 1:allow DGPFLMA3 to continue
+2 ; 0:DGPFLMA3 is to exit and return to LM screen
+3 ;
+4 ; Expected local variables from DGPFLMA3:
+5 ; DGPFA(), DGPFAH(), DGIEN
+6 ;
+7 NEW I,J,X,Y,ACT,CHG,DBRS,NM,OUT
+8 ;----- only select actions to be prompted for DBRS enter/edit
+9 SET ACT=+DGPFAH("ACTION")
IF "^2^3^4^6^"'[(U_ACT_U)
QUIT 1
+10 SET OUT=1
+11 ;
+12 ;----- initially set up the PRE and POST arrays to be the same
+13 DO GET(.DBRS,"PRE",DGIEN)
+14 MERGE DBRS("POST")=DBRS("PRE")
+15 ;----- inactivate action does not edit dbrs data
+16 IF ACT=3
DO EDTINACT
QUIT 1
+17 ;
+18 DO EDIT
IF OUT=-2
QUIT 0
+19 ;------ If no changes what action should LM take?
+20 ; If action="X", exit to LM menu
+21 ; If no data changes, no change to DGPFA(), setup DGPFAH()
+22 IF '$$EDITCHG
QUIT $SELECT(ACT=6:0,1:1)
+23 ;------ Set DGPFA() to be what it will look like if accept changes
+24 DO EDITPFA
+25 ;------ Build DBRS(0) which sorts data by DBRS#
+26 ; DBRS(0,dbrs#,1,field#) = pre-image value
+27 ; DBRS(0,dbrs#,2,field#) = post-image value
+28 DO EDITSORT
+29 ;------ Build DGPFAH()
+30 DO EDITPFAH
+31 QUIT 1
+32 ;
+33 ;=====================================================================
DBRSVAL(DGN,DGNIEN) ; validate DBRS#, check for uniqueness
+1 ; INPUT PARAMETERS:
+2 ; DGN - required - DBRS Number
+3 ; DGNIEN - optional - <26.131_ien>,<26.13_ien>
+4 ; if passed, 26.13_ien is required
+5 ; 26.131_ien can be "", n, or +n
+6 ; 26.13_ien required if passed
+7 ; if adding a new DBRS, 26.131_ien=""
+8 ; EXTRINSIC FUNCTION returns: p1^p2^p3 where
+9 ; p1 = -1:failed 0:passed with conditions 1:DBRS# unique
+10 ; p2 = message
+11 ; -1^message = failure
+12 ; 0^message = DGN passed, DGN assigned, but cannot determine
+13 ; if DGNIEN and that assignment are the same or
+14 ; that the DBRS internal record number match
+15 ; 0^iens = DGN passed, 26.13 values match, cannot determine
+16 ; if DBRS record number match. If DBRS#
+17 ; registered then iens=26.131ien,26.13ien
+18 ; 1[^iens] = DGN passes all business rules
+19 ; if appropriate pass back the existing IENS for
+20 ; that DBRS#
+21 ;
+22 NEW X,Y,ANS,ASGN,DA,DGA,DGERR,DIERR,DGRET,IEN,MSG
+23 SET MSG(1)="DBRS# not of the proper format"
+24 SET MSG(2)="Invalid IENS value received"
+25 SET MSG(3)="This DBRS# is already assigned to another assignment: #"
+26 SET MSG(4)="This DBRS# already assigned to this flag assignment"
+27 SET MSG(5)="Assignment IEN received does not exist: "
+28 SET DGNIEN=$GET(DGNIEN)
if DGNIEN=""
SET DGNIEN=",,"
+29 IF $LENGTH(DGNIEN,",")'=3
SET ANS="-1^2"
GOTO DVOUT
+30 ;
+31 ; check format of DBRS#
+32 IF '$LENGTH($GET(DGN))
SET ANS="-1^1"
GOTO DVOUT
+33 ;
+34 DO CHK^DIE(26.131,.01,,DGN,.DGRET,"DGERR")
KILL DA
+35 IF $DATA(DIERR)!(DGRET=U)
SET ANS="-1^1"
GOTO DVOUT
+36 ;
+37 ; check for uniqueness of DBRS#
+38 ; DA has existing IEN values for DBRS#
+39 ; DGA has iens from input DGNIEN
+40 SET (DA,DA(1))=0
+41 SET Y=$ORDER(^DGPF(26.13,"DBRS",DGN,0))
IF Y
Begin DoDot:1
+42 SET DA(1)=Y
SET DA=$ORDER(^DGPF(26.13,"DBRS",DGN,DA(1),0))
+43 QUIT
End DoDot:1
+44 SET DGA=$PIECE(DGNIEN,",")
+45 SET DGA(1)=$PIECE(DGNIEN,",",2)
+46 ; dbrs# is not already assigned
+47 IF 'DA(1)
SET ANS=1
GOTO DVOUT
+48 ; dbrs# is assigned to some assignment
+49 ; iens is adding a new assignment or looking for one
+50 IF $EXTRACT(DGA(1))="+"
SET ANS="-1^3^"_DA(1)
GOTO DVOUT
+51 IF $EXTRACT(DGA(1))="?"
SET ANS="0^3^"_DA(1)
GOTO DVOUT
+52 ; validate assignment ien passed in
+53 IF +DGA(1)=0
SET ANS="0^3^"_DA(1)
GOTO DVOUT
+54 IF +DGA(1)
IF '$DATA(^DGPF(26.13,DGA(1),0))
SET ANS="-1^5"_DGA(1)
GOTO DVOUT
+55 IF DGA(1)'=DA(1)
SET ANS="-1^3^"_DA(1)
GOTO DVOUT
+56 ; evaluate if trying to add DBRS a second time to an assignment
+57 IF 'DA
SET ANS=1
GOTO DVOUT
+58 IF $EXTRACT(DGA)="+"
SET ANS="-1^4"
GOTO DVOUT
+59 IF $EXTRACT(DGA)="?"
SET ANS="0^4"
GOTO DVOUT
+60 IF +DGA=0
SET ANS="0^4"
GOTO DVOUT
+61 IF DGA'=DA
SET ANS="-1^4"
GOTO DVOUT
+62 SET ANS=1
DVOUT ;
+1 SET X=$PIECE(ANS,U)
SET Y=$PIECE(ANS,U,2)
if Y
SET X=X_U_MSG(Y)_$PIECE(ANS,U,3)
+2 QUIT X
+3 ;
+4 ;=====================================================================
EIE(DGPFH) ; Message about EIE and deleting DBRS data
+1 ; INPUT: .DGPFH = .DGPFAH, see GETHIST^DGPFAAH for array description
+2 if '$DATA(DGPFH("DBRS"))
QUIT
+3 NEW I,X,Y,DGT,INC,JINC,NM,SP,TXT
+4 DO TEXT(.TXT,7,1)
+5 FOR I=1:1:3
SET DGT("DIMSG",I)=TXT(I)
+6 SET $PIECE(SP," ",21)=""
+7 SET INC=3
+8 SET (X,NM)=""
FOR JINC=0:0
SET JINC=$ORDER(DGPFH("DBRS",JINC))
if 'JINC
QUIT
Begin DoDot:1
+9 SET Y=DGPFH("DBRS",JINC)
SET NM=$PIECE(Y,U)
if $PIECE(Y,U,4)'="D"
QUIT
+10 SET X=X_$EXTRACT(NM_SP,1,20)
IF $LENGTH(X)>60
SET INC=INC+1
SET DGT("DIMSG",INC)=X
SET X=""
+11 QUIT
End DoDot:1
+12 IF $LENGTH(X)
SET INC=INC+1
SET DGT("DIMSG",INC)=X
+13 SET INC=INC+1
SET DGT("DIMAG",INC)=" "
+14 FOR J=4,5
SET INC=INC+1
SET DGT("DIMSG",INC)=TXT(J)
+15 SET INC=INC+1
SET DGT("DIMSG",INC)=" "
+16 DO MSG^DIALOG("MW",,,,"DGT")
+17 QUIT
+18 ;
+19 ;=====================================================================
+20 ; PRIVATE SUBROUTINES
+21 ;=====================================================================
ADD(DGIEN,DGDATA,DEL) ;
+1 ; INPUT PARAMETERS
+2 ; DGIEN - required - file 26.13 ien
+3 ; DEL - optional - 1:delete any existing dbrs#
+4 ; .DGDATA - optional - DBRS# to be added, do not add dups
+5 ; DGDATA(dbrs#) = iens for dbrs multiple
+6 ; first ien may be a number or +inc
+7 ; DGDATA(dbrs#,field#) = internal value
+8 ;
+9 NEW I,J,X,Y,DGERR,DGEXIST,DGFDA,DIERR,INC,NM
+10 if $GET(DGIEN)<1
QUIT
if $EXTRACT(DGIEN)="+"
QUIT
+11 if '$DATA(^DGPF(26.13,+DGIEN,0))
QUIT
+12 ; get any existing iens
DO GETDBRS^DGPFUT6(.DGEXIST,+DGIEN)
+13 IF +$GET(DEL)
DO DEL^DGPFUT6(+DGIEN,26.13)
KILL DGEXIST
+14 IF '$DATA(DGDATA)
QUIT
+15 SET INC=0
+16 SET NM=0
FOR I=0:0
SET NM=$ORDER(DGDATA(NM))
if NM=""
QUIT
Begin DoDot:1
+17 NEW IENS
+18 IF $DATA(DGEXIST(NM))
QUIT
+19 SET INC=INC+1
+20 SET IENS="+"_INC_","_(+DGIEN)_","
+21 SET DGFDA(26.131,IENS,.01)=NM
+22 SET X=$PIECE($GET(DGDATA(NM,.02)),U)
+23 IF $LENGTH(X)
IF X'="<no value>"
SET DGFDA(26.131,IENS,.02)=X
+24 SET X=$PIECE($GET(DGDATA(NM,.03)),U)
IF +X
SET DGFDA(26.131,IENS,.03)=X
+25 SET X=$PIECE($GET(DGDATA(NM,.04)),U)
IF +X
SET DGFDA(26.131,IENS,.04)=X
+26 QUIT
End DoDot:1
+27 IF $DATA(DGFDA)
DO UPDATE^DIE(,"DGFDA","DGERR")
+28 QUIT
+29 ;
+30 ; =============== FM ENTER/EDIT DBRS DATA ===============
EDIT ;
+1 ; Only certain actions allowed to edit DBRS#
+2 ; FOR loop allows for editing more than one DBRS#
+3 ; DBRS() reset if appropriate in each iteration through FOR loop
+4 ;
+5 NEW DGPRE
+6 DO EH
+7 FOR
Begin DoDot:1
+8 ; DATA := value of DBRS record data after DIC selection
+9 ; DATA(1) = after ^DIC, .01^.02^.03^.04^dbrs#_iens^new_flag
+10 ; DATA(2) = after ^DIR, .01^.02^.03^.04
+11 ; OUT := controller of FOR loop and ListManager action
+12 ; -2 := time_out, exit to Listmanager, make no changes
+13 ; -1 := finish editing, continue processing
+14 ; 1 := one DBRS# edit session completely successfully
+15 ;
+16 ;----- select or add a new DBRS record
+17 NEW X,Y,DGDIC,DGDIE,NM
+18 SET OUT=1
+19 Begin DoDot:2
+20 NEW X,DA,DIC,DLAYGO,DTOUT,DUOUT,TMP
+21 SET DA(1)=DGIEN
+22 SET DIC=$NAME(^DGPF(26.13,+DGIEN,2))
SET DIC=$TRANSLATE(DIC,")",",")
+23 SET DIC(0)="QAELMZn"
SET DLAYGO=26.131
+24 SET DIC("DR")=".02""DBRS Other"""
+25 WRITE !
DO ^DIC
IF $DATA(DTOUT)
SET OUT=-2
QUIT
+26 IF $DATA(DUOUT)!(Y<1)
SET OUT=-1
QUIT
+27 ; TMP = .01^.02^.03^.04^iens^new_flag
+28 SET TMP=Y(0)
SET $PIECE(TMP,U,5)=(+Y)_","_DGIEN_","_U_$PIECE(Y,U,3)
+29 ; is new record a duplicate?
+30 IF +$PIECE(TMP,U,6)
IF $DATA(DBRS("POST",$PIECE(TMP,U)))
Begin DoDot:3
+31 SET OUT=0
WRITE !
DO TEXT(,1)
WRITE !
+32 NEW Y,DA,DIK
+33 SET Y=$PIECE(TMP,U,5)
SET DA=+Y
SET DA(1)=+$PIECE(Y,",",2)
SET DIK=DIC
DO ^DIK
+34 QUIT
End DoDot:3
SET OUT=0
+35 SET DGDIC=TMP
+36 QUIT
End DoDot:2
IF OUT<0
QUIT
+37 ;
+38 IF '$DATA(DGDIC)
SET OUT=-1
QUIT
+39 SET DGDIE=$PIECE(DGDIC,U,1,4)
+40 ;
+41 ;----- if existing record selected, allow editing of .01 field
+42 IF '$PIECE(DGDIC,U,6)
IF DGDIE'="@"
Begin DoDot:2
+43 NEW A,X,Y,DR,DIE,DR,DTOUT,DUOUT,PRE
+44 SET A=$PIECE(DGDIC,U,5)
SET DA=+A
SET DA(1)=+$PIECE(A,",",2)
+45 SET PRE=^DGPF(26.13,DA(1),2,DA,0)
+46 SET DIE=$NAME(^DGPF(26.13,+DGIEN,2))
SET DIE=$TRANSLATE(DIE,")",",")
+47 SET DR=".01;.02"
+48 WRITE !
DO ^DIE
+49 IF $DATA(DTOUT)
SET OUT=-2
QUIT
+50 SET A=$PIECE(DGDIC,U,5)
SET DA=+A
SET DA(1)=+$PIECE(A,",",2)
+51 SET X=$GET(^DGPF(26.13,DA(1),2,DA,0))
+52 IF X=""
SET DGDIE="@"
QUIT
+53 IF '$TEST
SET DGDIE=X
+54 IF $PIECE(X,U)=$PIECE(PRE,U)
QUIT
+55 IF '$DATA(DBRS("POST",$PIECE(X,U)))
QUIT
+56 WRITE !
DO TEXT(,3)
WRITE !
SET OUT=0
+57 SET DR=".01///"_$PIECE(PRE,U)_";.02///"_$PIECE(PRE,U,2)
DO ^DIE
+58 QUIT
End DoDot:2
IF OUT<1
QUIT
+59 ;
+60 ;----- now make changes to DBRS()
+61 SET NM=$PIECE(DGDIC,U)
+62 SET NM(1)=$PIECE(DGDIE,U)
+63 ; new record added
+64 IF +$PIECE(DGDIC,U,6)
Begin DoDot:2
+65 SET DBRS("POST",NM)=$PIECE(DGDIC,U,5)
+66 SET DBRS("POST",NM,.01)=$PIECE(DGDIC,U,1)
+67 SET DBRS("POST",NM,.02)=$PIECE(DGDIC,U,2)
+68 SET DBRS("POST",NM,.03)=$PIECE(DGDIC,U,3)
+69 SET DBRS("POST",NM,.04)=$PIECE(DGDIC,U,4)
+70 QUIT
End DoDot:2
QUIT
+71 ; existing record to be deleted
+72 IF NM(1)="@"
KILL DBRS("POST",NM)
QUIT
+73 ; existing record .01 field value changed
+74 IF NM'=NM(1)
Begin DoDot:2
+75 KILL DBRS("POST",NM)
+76 SET DBRS("POST",NM(1))=$PIECE(DGDIC,U,5)
+77 SET DBRS("POST",NM(1),.01)=$PIECE(DGDIE,U,1)
+78 SET DBRS("POST",NM(1),.02)=$PIECE(DGDIE,U,2)
+79 SET DBRS("POST",NM(1),.03)=$PIECE(DGDIE,U,3)
+80 SET DBRS("POST",NM(1),.04)=$PIECE(DGDIE,U,4)
+81 QUIT
End DoDot:2
QUIT
+82 ; dbrs# unchanged, OTHER may or may not have changed
+83 SET DBRS("POST",NM(1),.02)=$PIECE(DGDIE,U,2)
+84 QUIT
End DoDot:1
if OUT<0
QUIT
+85 ; Reset 26.13 file DBRS data to pre-edit state
+86 MERGE DGPRE=DBRS("PRE")
DO ADD(DGIEN,.DGPRE,1)
+87 QUIT
+88 ;
EDITCHG() ;----- check to see if any data changed at all
+1 NEW J,X,CHG,INC,NM
+2 SET CHG=0
+3 SET NM=0
FOR J=0:0
SET NM=$ORDER(DBRS("PRE",NM))
if NM=""
QUIT
Begin DoDot:1
+4 IF DBRS("PRE",NM,.01)'=$GET(DBRS("POST",NM,.01))
SET CHG=1
+5 IF DBRS("PRE",NM,.02)'=$GET(DBRS("POST",NM,.02))
SET CHG=1
+6 QUIT
End DoDot:1
if CHG
QUIT
+7 IF 'CHG
SET NM=0
FOR J=0:0
SET NM=$ORDER(DBRS("POST",NM))
if NM=""
QUIT
Begin DoDot:1
+8 IF DBRS("POST",NM,.01)'=$GET(DBRS("PRE",NM,.01))
SET CHG=1
+9 IF DBRS("POST",NM,.02)'=$GET(DBRS("PRE",NM,.02))
SET CHG=1
+10 QUIT
End DoDot:1
if CHG
QUIT
+11 IF 'CHG
DO EDTINACT
+12 QUIT CHG
+13 ;
EDTINACT ; set up DGPFAH() if no change
+1 NEW J,X,INC,NM
+2 SET INC=0
+3 SET NM=0
FOR J=0:0
SET NM=$ORDER(DBRS("PRE",NM))
if NM=""
QUIT
Begin DoDot:1
+4 SET X=DBRS("PRE",NM,.01)_U_DBRS("PRE",NM,.02)_U_DBRS("PRE",NM,.03)
+5 SET X=X_U_"N"_U_DBRS("PRE",NM,.04)
+6 SET INC=INC+1
SET DGPFAH("DBRS",INC)=X
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
EDITPFA ;----- set DGPFA() to values if changes accepted
+1 NEW J,X,NM
+2 FOR X="DBRS#","DBRS OTHER","DBRS DATE","DBRS SITE"
KILL DGPFA(X)
+3 SET (J,NM)=0
FOR J=0:0
SET NM=$ORDER(DBRS("POST",NM))
if NM=""
QUIT
Begin DoDot:1
+4 SET J=J+1
+5 SET DGPFA("DBRS#",J)=DBRS("POST",NM,.01)_U_$$EXT(NM,.01)
+6 SET DGPFA("DBRS OTHER",J)=DBRS("POST",NM,.02)_U_$$EXT(NM,.02)
+7 SET DGPFA("DBRS DATE",J)=DBRS("POST",NM,.03)_U_$$EXT(NM,.03)
+8 SET DGPFA("DBRS SITE",J)=DBRS("POST",NM,.04)_U_$$EXT(NM,.04)
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
EDITPFAH ;----- Create DGPFAH()
+1 NEW I,J,X,Y,INC,NM
+2 SET (INC,NM)=0
FOR I=0:0
SET NM=$ORDER(DBRS(0,NM))
if NM=""
QUIT
Begin DoDot:1
+3 NEW PRE,POST
+4 SET PRE=""
IF $DATA(DBRS(0,NM,1))
Begin DoDot:2
+5 SET $PIECE(PRE,U,1)=$GET(DBRS(0,NM,1,.01))
+6 SET $PIECE(PRE,U,2)=$GET(DBRS(0,NM,1,.02))
+7 SET $PIECE(PRE,U,3)=$GET(DBRS(0,NM,1,.03))
+8 SET $PIECE(PRE,U,5)=$GET(DBRS(0,NM,1,.04))
+9 QUIT
End DoDot:2
+10 SET POST=""
IF $DATA(DBRS(0,NM,2))
Begin DoDot:2
+11 SET $PIECE(POST,U,1)=$GET(DBRS(0,NM,2,.01))
+12 SET $PIECE(POST,U,2)=$GET(DBRS(0,NM,2,.02))
+13 SET $PIECE(POST,U,3)=$GET(DBRS(0,NM,2,.03))
+14 SET $PIECE(POST,U,5)=$GET(DBRS(0,NM,2,.04))
+15 QUIT
End DoDot:2
+16 SET INC=INC+1
+17 ;----- no changes to DBRS
+18 IF PRE=POST
if PRE'=""
SET $PIECE(PRE,U,4)="N"
SET DGPFAH("DBRS",INC)=PRE
QUIT
+19 ;----- POST="", DBRS deleted
+20 IF POST=""
SET $PIECE(PRE,U,4)="D"
SET DGPFAH("DBRS",INC)=PRE
QUIT
+21 ;----- PRE="", DBRS added
+22 IF PRE=""
SET $PIECE(POST,U,4)="A"
SET DGPFAH("DBRS",INC)=POST
QUIT
+23 ;----- DBRS record edited
+24 ; If date/site exist, may not be changed
+25 SET $PIECE(POST,U,4)="E"
+26 SET X=$PIECE(PRE,U,3)
IF X>0
IF $PIECE(POST,U,3)'=X
SET $PIECE(POST,U,3)=X
+27 SET X=$PIECE(PRE,U,5)
IF X>0
IF $PIECE(POST,U,5)'=X
SET $PIECE(POST,U,5)=X
+28 SET DGPFAH("DBRS",INC)=POST
+29 QUIT
End DoDot:1
+30 QUIT
+31 ;
EDITSORT ;----- Sort the DBRS() by DBRS#
+1 NEW I,NM
+2 SET NM=0
+3 FOR I=0:0
SET NM=$ORDER(DBRS("PRE",NM))
if NM=""
QUIT
MERGE DBRS(0,NM,1)=DBRS("PRE",NM)
+4 SET NM=0
+5 FOR I=0:0
SET NM=$ORDER(DBRS("POST",NM))
if NM=""
QUIT
MERGE DBRS(0,NM,2)=DBRS("POST",NM)
+6 QUIT
+7 ;
EH ;
+1 ;;You may add, edit, or delete a DBRS entry for this assignment.
+2 ;;To delete an entry, use the '@' sign after '//'.
+3 ;;
+4 NEW I,X,Y
+5 WRITE !
+6 FOR I=1:1
SET X=$PIECE($TEXT(EH+I),";;",2)
if X=""
QUIT
WRITE !,X
+7 ; S X=$$ANSWER^DGPFUT("Press any key to continue",,"E")
+8 QUIT
+9 ;
EXT(DBS,FLD) ; get external value
+1 ; DBS = DBRS#
+2 ; FLD = field number
+3 NEW X,Y
+4 SET Y=""
SET X=$GET(DBRS("POST",NM,FLD))
+5 IF FLD=.01
SET Y=X
+6 IF FLD=.02
SET Y=X
if X=""
SET Y="<no value>"
+7 IF FLD=.03
IF X>0
SET Y=$$FMTE^XLFDT(X,"5Z")
+8 IF FLD=.04
IF X>0
SET Y=$PIECE($$NS^XUAF4(X),U)
+9 QUIT Y
+10 ;
GET(DBRS,NODE,IEN) ;
+1 ; get dbrs records from 26.13
+2 ; only return DBRS() with internal FM form of the data
+3 ; .DBRS - return array
+4 ; NODE = PRE or POST
+5 ; IEN = file 26.13 ien
+6 NEW I,DGRET,NM
+7 if $GET(IEN)<1
QUIT
+8 DO GETDBRS^DGPFUT6(.DGRET,IEN)
+9 ; see GETDBRS^DGPRUT62 for description of .DGRET
+10 SET DBRS(NODE)=0
+11 SET (I,NM)=0
FOR
SET NM=$ORDER(DGRET(NM))
if NM=""
QUIT
Begin DoDot:1
+12 SET DBRS(NODE)=1+$GET(DBRS(NODE))
+13 ; iens
SET DBRS(NODE,NM)=DGRET(NM)
+14 SET DBRS(NODE,NM,.01)=NM
+15 SET DBRS(NODE,NM,.02)=$PIECE(DGRET(NM,"OTHER"),U)
+16 SET DBRS(NODE,NM,.03)=$PIECE(DGRET(NM,"DATE"),U)
+17 SET DBRS(NODE,NM,.04)=$PIECE(DGRET(NM,"SITE"),U)
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
NOW() NEW I,X,Y,Z
QUIT $EXTRACT($$NOW^XLFDT,1,12)
+1 ;
TEXT(TXT,ST,NOWR) ;
+1 NEW I,J,X
SET J=0
+2 FOR I=ST:1
SET X=$PIECE($TEXT(T+I),";",3,9)
if X="[end]"
QUIT
SET J=J+1
SET TXT(J)=" "_X
+3 IF '$GET(NOWR)
FOR I=1:1
if '$DATA(TXT(I))
QUIT
WRITE !,TXT(I)
+4 QUIT
T ;
+1 ;;This DBRS# Number is already associated with this assignment.
+2 ;;[end]
+3 ;;You have changed the name of an existing DBRS Number to be the same
+4 ;;as an existing DBRS entry for this flag assignment. This is not
+5 ;;allowed.
+6 ;;[end]
+7 ;;
+8 ;;You have marked this assignment as Entered In Error
+9 ;;All of the following DBRS Numbers will be removed from this assignment:
+10 ;;DO NOT file the assignment if you do not wish these DBRS Numbers
+11 ;;removed from this assignment.
+12 ;;[end]
