Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPFUT61

DGPFUT61.m

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