- 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 Jan 18, 2025@03:49:36 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]