- DGPFUT62 ;SHRPE/SGM - PRF DBRS FILE/GET/SORT ; Mar 1, 2018 17:20
- ;;5.3;Registration;**951**;Aug 13, 1993;Build 135
- ; Last Edited: SHRPE/SGM - Oct 08, 2018 11:08
- ;
- ; ^DGPFUT6 is the only component to directly reference this routine
- ;
- ; ICR# TYPE DESCRIPTION
- ;----- ---- -----------------------------------------
- ; 2056 Sup $$GET1^DIQ, GETS^DIQ
- ; 2051 Sup $$FIND1^DIC
- ; 2053 Sup ^DIE: FILE, UPDATE
- ;10013 Sup ^DIK
- ;10112 Sup $$SITE^VASITE
- ;
- ;=====================================================================
- AASGN(DGIENS,DGPFIN,DGFDA,DGPFUV,DGPFERR) ;
- ; Called from STOASGN^DGPFAA
- ;BUSINESS RULES:
- ; 1. Create FDA(), do not change any data in existing files
- ; Calling program will call FILE^DIE or UPDATE^DIE
- ; 2. Calling program may add DGPFA("ACTION") if it has an associated
- ; History record.
- ; 3. If ACTION is 3 (Inactive) no DBRS data edited
- ; 4. If ACTION is 5 (EIE), delete all existing DBRS data, add no new
- ; DBRS data
- ; 5. If ACTION is 7 (Refresh), delete all existing DBRS before adding
- ; 6. Updates called from processing HL7 message
- ; May set DGPFA("DBRS ACTION") = U:add/update D:delete
- ; Applies to that one DBRS record only
- ; 7. DBRS DATE and SITE fields may not be overwritten except for
- ; Refresh
- ; 8. Only REFRESH action is authorized to overwrite an existing field
- ; values for DATE and CREATE SITE
- ;
- ;INPUT PARAMETERS:
- ; DGIENS - 26.13 iens, may be +N, or N,
- ; .DGPFIN - DGPFA() passed by reference - see DGPFAA for details
- ; .DGFDA - FDA() array to be populated, may have existing values
- ; DGPFUV - optional - default to "", consists of single character
- ; ="D" delete all existing DBRS records before adding others
- ; ="d" delete all existing DBRS record, quit, do not
- ; continue processing in this module
- ; ="" only act upon DBRS# indicated in DGPFA()
- ;
- ;RETURN PARAMETERS:
- ; .DGFDA - FDA() array to be populated if appropriate
- ; .DGPFERR - error message array
- ; $D(DGPFERR) - fail, calling program does not continue
- ; '$D(DGPFERR) - calling program continues
- ;
- N I,J,X,ACT,FAC,DBRS,DGDBRS,DIEN,INC,NOW,SITE
- ; initialize local variables
- I '$L($G(DGIENS)) Q
- S:$E(DGIENS,$L(DGIENS))'="," DGIENS=DGIENS_","
- S NOW=+$E($$NOW^XLFDT,1,12)
- S FAC=+$$SITE^VASITE
- S ACT=+$G(DGPFIN("ACTION"))
- S DGPFUV=$$UV^DGPFAA Q:DGPFUV=-1
- I ACT=5,DGPFUV'="d" S DGPFUV="d"
- I ACT=3 Q ; no editing of DBRS data for inactivate
- ; do not set up DGFDA()
- ;
- ; see GETDBRS for array description
- ; DBRS(dbrs#,1) = 26.131_iens
- ; DBRS(dbrs#,1,sub) = pre_edit_image
- ; DBRS(dbrs#,2) = < does not exist >
- ; DBRS(dbrs#,2,sub) = post_edit_image
- ;
- ; get current DBRS records on file (PRE-image)
- I DGIENS'["+" D
- . N X,ARR
- . D GETDBRS(.ARR,DGIENS)
- . I $G(ARR(0))>0 S X=0 F S X=$O(ARR(X)) Q:X="" D
- . . S DBRS(X,1)=ARR(X) ; 26.131 iens value
- . . S DBRS(X,1,"DBRS#")=X
- . . S DBRS(X,1,"OTHER")=$P($G(ARR(X,"OTHER")),U)
- . . S DBRS(X,1,"DATE")=$P($G(ARR(X,"DATE")),U)
- . . S DBRS(X,1,"SITE")=$P($G(ARR(X,"SITE")),U)
- . . Q
- . Q
- ;
- ; moved INPUT data to DBRS(dbrs#,2) [POST-image]
- S I=0 F J=0:0 S I=$O(DGPFIN("DBRS#",I)) Q:'I D
- . N X,Y
- . S DBRS=$P(DGPFIN("DBRS#",I),U)
- . S DBRS(DBRS,2,"DBRS#")=DBRS
- . S Y=$P(DGPFIN("DBRS OTHER",I),U) S:Y="<no value>" Y=""
- . S DBRS(DBRS,2,"OTHER")=Y
- . S Y=$P(DGPFIN("DBRS DATE",I),U)
- . S DBRS(DBRS,2,"DATE")=Y
- . S Y=$P(DGPFIN("DBRS SITE",I),U)
- . S DBRS(DBRS,2,"SITE")=Y
- . ; DBRS ACTION only comes from HL7 message processing
- . ; Set ACT to -1 if not coming from HL7 processing
- . S X=$G(DGPFIN("DBRS ACTION",I),-1)
- . S DBRS(DBRS,2,"ACT")=$P(X,U)
- . Q
- ;
- ; set up FDA()
- ;
- ; if DGPFUV="d" or ="D" then set all existing DBRS records to be
- ; deleted. Edits may override delete
- ; if DGPFUV="" then called from PRF HL processor, only act upon
- ; specific DBRS# listed in DGPFA()
- ;
- I DGPFUV="D"!(DGPFUV="d") D
- . N X,Y,IENS,NM
- . S NM="" F S NM=$O(DBRS(NM)) Q:NM="" I $D(DBRS(NM,1)) D
- . . S IENS=DBRS(NM,1),DGFDA(26.131,IENS,.01)="@"
- . . Q
- . Q
- I DGPFUV="d" Q
- ;
- S INC=10 ; incrementor used for add new DBRS record
- S DBRS=0 F J=0:0 S DBRS=$O(DBRS(DBRS)) Q:DBRS="" D
- . N ACT,HLACT,DIEN,IENS
- . S IENS=$G(DBRS(DBRS,1))
- . S HLACT=$G(DBRS(DBRS,2,"ACT"))
- . S ACT=+$G(DGPFIN("ACTION"))
- . ;
- . ; PRE exists, POST does not; record deleted if DGPFUV="D"
- . I $D(DBRS(DBRS,1)),'$D(DBRS(DBRS,2)) Q
- . ;
- . ; POST exists, PRE does not, adding a new record
- . ; Post DBRS action may be Delete
- . I $D(DBRS(DBRS,2)),'$D(DBRS(DBRS,1)) D Q
- . . I HLACT="D" Q
- . . S INC=INC+1,DIEN="+"_INC_","_DGIENS
- . . S DGFDA(26.131,DIEN,.01)=DBRS
- . . S X=DBRS(DBRS,2,"OTHER") S:$L(X) DGFDA(26.131,DIEN,.02)=X
- . . S X=DBRS(DBRS,2,"DATE") S:+X DGFDA(26.131,DIEN,.03)=X
- . . S X=DBRS(DBRS,2,"SITE") S:+X DGFDA(26.131,DIEN,.04)=X
- . . Q
- . ;
- . ; Both PRE and POST exists, update existing record
- . ; conditional update of fields .03,.04
- . I HLACT="D" S DGFDA(26.131,IENS,.01)="@" Q
- . K DGFDA(26.131,IENS,.01)
- . S X=$G(DBRS(DBRS,1,"OTHER")),Y=$G(DBRS(DBRS,2,"OTHER")) D
- . . I X'=Y S DGFDA(26.131,IENS,.02)=Y
- . . Q
- . S X=$G(DBRS(DBRS,1,"DATE")),Y=$G(DBRS(DBRS,2,"DATE")) D
- . . I $S((ACT=7)!(ACT=8):1,+X:0,1:+Y) S DGFDA(26.131,IENS,.03)=Y
- . . Q
- . S X=$G(DBRS(DBRS,1,"SITE")),Y=$G(DBRS(DBRS,2,"SITE")) D
- . . I $S((ACT=7)!(ACT=8):1,+X:0,1:+Y) S DGFDA(26.131,IENS,.04)=Y
- . . Q
- . Q
- Q
- ;
- ;=====================================================================
- DEL(DGXIEN,DGFILE) ;
- ; delete all DBRS records for a flag assignment or history record
- ; QA on input values done in DGPFUT6
- Q:'$G(DGXIEN) Q:'$G(DGFILE)
- S DGXIEN=+DGXIEN
- Q:'$O(^DGPF(DGFILE,DGXIEN,2,0))
- Q:"^26.13^26.14^"'[(U_DGFILE_U)
- N X,Y,DA,DGDBRSE,DIK
- S DGDBRSE=1 ; not need but cya, DEL node on ^DD(26.131,.01)
- S DIK="^DGPF("_DGFILE_","_DGXIEN_",2," S DA(1)=DGIEN
- S DA=0 F S DA=$O(^DGPF(DGFILE,DGXIEN,2,DA)) Q:'DA D ^DIK
- Q
- ;
- ;=====================================================================
- GETDBRS(DGRET,DGAIEN) ;
- ;Return all DBRS data associated with a CAT I BEHAVIORAL assignment
- ;INPUT PARAMETER: DGPFIEN - req - file_26.13_ien
- ;RETURN VALUES:
- ; .DGRET(0) = total number of DBRS records [0,1,2,...]
- ; .DGRET(dbrs#) = <26.131_ien>,<26.13_ien>, [iens]
- ; (dbrs#,"DBRS#") = internal^external [#.01]
- ; (dbrs#,"OTHER") = internal^external [#.02]
- ; (dbrs#,"DATE") = internal^external [#.03]
- ; (dbrs#,"SITE") = internal^external [#.04]
- ;
- N X,Y,DGARR,DGIEN,DGERR,DIERR,IENS
- S DGRET(0)=0
- S DGAIEN=$G(DGAIEN) Q:$E(DGAIEN)="+" Q:'DGAIEN
- ;
- S DGIEN=(+DGAIEN)_","
- D GETS^DIQ(26.13,DGIEN,".02;2*","IE","DGARR","DGERR")
- Q:$D(DIERR)
- Q:DGARR(26.13,DGIEN,.02,"I")'[26.15
- Q:DGARR(26.13,DGIEN,.02,"E")'="BEHAVIORAL"
- S IENS=0 F S IENS=$O(DGARR(26.131,IENS)) Q:'IENS D
- . N DBRS,TMP M TMP=DGARR(26.131,IENS)
- . S DBRS=TMP(.01,"E")
- . S DGRET(0)=1+DGRET(0)
- . S DGRET(DBRS)=IENS
- . S DGRET(DBRS,"DBRS#")=TMP(.01,"I")_U_TMP(.01,"E")
- . S DGRET(DBRS,"OTHER")=TMP(.02,"I")_U_TMP(.02,"E")
- . S DGRET(DBRS,"DATE")=TMP(.03,"I")_U_TMP(.03,"E")
- . S DGRET(DBRS,"SITE")=TMP(.04,"I")_U_TMP(.04,"E")
- . Q
- Q
- ;
- ;=====================================================================
- GETDBRSH(DGRET,DGHIEN) ;
- ; Get DBRS data for a History record
- ;INPUT PARAMETERS: DGPFIEN - req - ien to file 26.14
- ;RETURN VALUES:
- ; .DGRET(0) = total number of DBRS records
- ; .DGRET(dbrs#) = <26.142_ien>,<26.14_ien>, [iens]
- ; (dbrs#,"DBRS#") = internal^external [#.01]
- ; (dbrs#,"OTHER") = internal^external [#.02]
- ; (dbrs#,"DATE") = internal^external [#.03]
- ; (dbrs#,"STAT") = internal^external [#.04]
- ; (dbrs#,"SITE") = internal^external [#.05]
- ;
- S DGRET(0)=0
- S DGHIEN=$G(DGHIEN)
- I DGHIEN,$D(^DGPF(26.14,DGHIEN,2)) D
- . N DGARR,DGERR,DIERR,IEN,IENS
- . S IENS=(+DGHIEN)_","
- . D GETS^DIQ(26.14,IENS,"2*","IE","DGARR","DGERR")
- . Q:$D(DIERR)
- . S IEN=0 F S IEN=$O(DGARR(26.142,IEN)) Q:'IEN D
- . . N DBRS,TMP
- . . M TMP=DGARR(26.142,IEN)
- . . S DBRS=TMP(.01,"E")
- . . S DGRET(0)=1+DGRET(0)
- . . S DGRET(DBRS)=IEN
- . . S DGRET(DBRS,"DBRS#")=TMP(.01,"I")_U_TMP(.01,"E")
- . . S DGRET(DBRS,"OTHER")=TMP(.02,"I")_U_TMP(.02,"E")
- . . S DGRET(DBRS,"DATE")=TMP(.03,"I")_U_$P(TMP(.03,"E"),":",1,2)
- . . S DGRET(DBRS,"STAT")=TMP(.04,"I")_U_TMP(.04,"E")
- . . S DGRET(DBRS,"SITE")=TMP(.05,"I")_U_TMP(.05,"E")
- . . Q
- . Q
- Q
- ;
- ;=====================================================================
- STOHIST(DGIENS,DGFLD,DGFDA,DGPFERR) ;
- ; Set up FDA() for use in UPDATE^DIE
- ; For more information on input params, see STOHIST^DGPFAAH
- ;INPUT PARAMETERS:
- ; DGIENS - req - fda() iens to file 26.14, may be "+1,"
- ; .DGFLD - req - subset of DGPFAH()
- ;RETURN PARAMETERS:
- ; .DGFDA - FDA array of UPDATE^DIE
- ; DGFDA() may have existing nodes unrelated to DBRS
- ; .DGPFERR - error array to return to calling program
- ;
- N I,J,IEN,INC
- S DGIENS=$G(DGIENS) I DGIENS="" Q
- I $E(DGIENS)'="+",'$D(^DGPF(26.14,+DGIENS,0)) Q
- Q:'$D(DGFLD("DBRS"))
- ;
- S INC=50,I=0 F J=0:0 S I=$O(DGFLD("DBRS",I)) Q:'I D
- . N J,IENS,INP
- . ; expects DGFLD("DBRS",I) to consist of 5 single valued pieces
- . F J=1:1:5 S INP(J)=$P(DGFLD("DBRS",I),U,J)
- . S INC=INC+1,IENS="+"_INC_","_DGIENS
- . S DGFDA(26.142,IENS,.01)=INP(1) ; DBRS#
- . I $L(INP(2)) S DGFDA(26.142,IENS,.02)=INP(2) ; OTHER
- . I +INP(3) S DGFDA(26.142,IENS,.03)=INP(3) ; DATE
- . I INP(4)?1U S DGFDA(26.142,IENS,.04)=INP(4) ; STAT
- . I +INP(5) S DGFDA(26.142,IENS,.05)=INP(5) ; SITE
- . Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFUT62 9924 printed Feb 19, 2025@00:14:58 Page 2
- DGPFUT62 ;SHRPE/SGM - PRF DBRS FILE/GET/SORT ; Mar 1, 2018 17:20
- +1 ;;5.3;Registration;**951**;Aug 13, 1993;Build 135
- +2 ; Last Edited: SHRPE/SGM - Oct 08, 2018 11:08
- +3 ;
- +4 ; ^DGPFUT6 is the only component to directly reference this routine
- +5 ;
- +6 ; ICR# TYPE DESCRIPTION
- +7 ;----- ---- -----------------------------------------
- +8 ; 2056 Sup $$GET1^DIQ, GETS^DIQ
- +9 ; 2051 Sup $$FIND1^DIC
- +10 ; 2053 Sup ^DIE: FILE, UPDATE
- +11 ;10013 Sup ^DIK
- +12 ;10112 Sup $$SITE^VASITE
- +13 ;
- +14 ;=====================================================================
- AASGN(DGIENS,DGPFIN,DGFDA,DGPFUV,DGPFERR) ;
- +1 ; Called from STOASGN^DGPFAA
- +2 ;BUSINESS RULES:
- +3 ; 1. Create FDA(), do not change any data in existing files
- +4 ; Calling program will call FILE^DIE or UPDATE^DIE
- +5 ; 2. Calling program may add DGPFA("ACTION") if it has an associated
- +6 ; History record.
- +7 ; 3. If ACTION is 3 (Inactive) no DBRS data edited
- +8 ; 4. If ACTION is 5 (EIE), delete all existing DBRS data, add no new
- +9 ; DBRS data
- +10 ; 5. If ACTION is 7 (Refresh), delete all existing DBRS before adding
- +11 ; 6. Updates called from processing HL7 message
- +12 ; May set DGPFA("DBRS ACTION") = U:add/update D:delete
- +13 ; Applies to that one DBRS record only
- +14 ; 7. DBRS DATE and SITE fields may not be overwritten except for
- +15 ; Refresh
- +16 ; 8. Only REFRESH action is authorized to overwrite an existing field
- +17 ; values for DATE and CREATE SITE
- +18 ;
- +19 ;INPUT PARAMETERS:
- +20 ; DGIENS - 26.13 iens, may be +N, or N,
- +21 ; .DGPFIN - DGPFA() passed by reference - see DGPFAA for details
- +22 ; .DGFDA - FDA() array to be populated, may have existing values
- +23 ; DGPFUV - optional - default to "", consists of single character
- +24 ; ="D" delete all existing DBRS records before adding others
- +25 ; ="d" delete all existing DBRS record, quit, do not
- +26 ; continue processing in this module
- +27 ; ="" only act upon DBRS# indicated in DGPFA()
- +28 ;
- +29 ;RETURN PARAMETERS:
- +30 ; .DGFDA - FDA() array to be populated if appropriate
- +31 ; .DGPFERR - error message array
- +32 ; $D(DGPFERR) - fail, calling program does not continue
- +33 ; '$D(DGPFERR) - calling program continues
- +34 ;
- +35 NEW I,J,X,ACT,FAC,DBRS,DGDBRS,DIEN,INC,NOW,SITE
- +36 ; initialize local variables
- +37 IF '$LENGTH($GET(DGIENS))
- QUIT
- +38 if $EXTRACT(DGIENS,$LENGTH(DGIENS))'=","
- SET DGIENS=DGIENS_","
- +39 SET NOW=+$EXTRACT($$NOW^XLFDT,1,12)
- +40 SET FAC=+$$SITE^VASITE
- +41 SET ACT=+$GET(DGPFIN("ACTION"))
- +42 SET DGPFUV=$$UV^DGPFAA
- if DGPFUV=-1
- QUIT
- +43 IF ACT=5
- IF DGPFUV'="d"
- SET DGPFUV="d"
- +44 ; no editing of DBRS data for inactivate
- IF ACT=3
- QUIT
- +45 ; do not set up DGFDA()
- +46 ;
- +47 ; see GETDBRS for array description
- +48 ; DBRS(dbrs#,1) = 26.131_iens
- +49 ; DBRS(dbrs#,1,sub) = pre_edit_image
- +50 ; DBRS(dbrs#,2) = < does not exist >
- +51 ; DBRS(dbrs#,2,sub) = post_edit_image
- +52 ;
- +53 ; get current DBRS records on file (PRE-image)
- +54 IF DGIENS'["+"
- Begin DoDot:1
- +55 NEW X,ARR
- +56 DO GETDBRS(.ARR,DGIENS)
- +57 IF $GET(ARR(0))>0
- SET X=0
- FOR
- SET X=$ORDER(ARR(X))
- if X=""
- QUIT
- Begin DoDot:2
- +58 ; 26.131 iens value
- SET DBRS(X,1)=ARR(X)
- +59 SET DBRS(X,1,"DBRS#")=X
- +60 SET DBRS(X,1,"OTHER")=$PIECE($GET(ARR(X,"OTHER")),U)
- +61 SET DBRS(X,1,"DATE")=$PIECE($GET(ARR(X,"DATE")),U)
- +62 SET DBRS(X,1,"SITE")=$PIECE($GET(ARR(X,"SITE")),U)
- +63 QUIT
- End DoDot:2
- +64 QUIT
- End DoDot:1
- +65 ;
- +66 ; moved INPUT data to DBRS(dbrs#,2) [POST-image]
- +67 SET I=0
- FOR J=0:0
- SET I=$ORDER(DGPFIN("DBRS#",I))
- if 'I
- QUIT
- Begin DoDot:1
- +68 NEW X,Y
- +69 SET DBRS=$PIECE(DGPFIN("DBRS#",I),U)
- +70 SET DBRS(DBRS,2,"DBRS#")=DBRS
- +71 SET Y=$PIECE(DGPFIN("DBRS OTHER",I),U)
- if Y="<no value>"
- SET Y=""
- +72 SET DBRS(DBRS,2,"OTHER")=Y
- +73 SET Y=$PIECE(DGPFIN("DBRS DATE",I),U)
- +74 SET DBRS(DBRS,2,"DATE")=Y
- +75 SET Y=$PIECE(DGPFIN("DBRS SITE",I),U)
- +76 SET DBRS(DBRS,2,"SITE")=Y
- +77 ; DBRS ACTION only comes from HL7 message processing
- +78 ; Set ACT to -1 if not coming from HL7 processing
- +79 SET X=$GET(DGPFIN("DBRS ACTION",I),-1)
- +80 SET DBRS(DBRS,2,"ACT")=$PIECE(X,U)
- +81 QUIT
- End DoDot:1
- +82 ;
- +83 ; set up FDA()
- +84 ;
- +85 ; if DGPFUV="d" or ="D" then set all existing DBRS records to be
- +86 ; deleted. Edits may override delete
- +87 ; if DGPFUV="" then called from PRF HL processor, only act upon
- +88 ; specific DBRS# listed in DGPFA()
- +89 ;
- +90 IF DGPFUV="D"!(DGPFUV="d")
- Begin DoDot:1
- +91 NEW X,Y,IENS,NM
- +92 SET NM=""
- FOR
- SET NM=$ORDER(DBRS(NM))
- if NM=""
- QUIT
- IF $DATA(DBRS(NM,1))
- Begin DoDot:2
- +93 SET IENS=DBRS(NM,1)
- SET DGFDA(26.131,IENS,.01)="@"
- +94 QUIT
- End DoDot:2
- +95 QUIT
- End DoDot:1
- +96 IF DGPFUV="d"
- QUIT
- +97 ;
- +98 ; incrementor used for add new DBRS record
- SET INC=10
- +99 SET DBRS=0
- FOR J=0:0
- SET DBRS=$ORDER(DBRS(DBRS))
- if DBRS=""
- QUIT
- Begin DoDot:1
- +100 NEW ACT,HLACT,DIEN,IENS
- +101 SET IENS=$GET(DBRS(DBRS,1))
- +102 SET HLACT=$GET(DBRS(DBRS,2,"ACT"))
- +103 SET ACT=+$GET(DGPFIN("ACTION"))
- +104 ;
- +105 ; PRE exists, POST does not; record deleted if DGPFUV="D"
- +106 IF $DATA(DBRS(DBRS,1))
- IF '$DATA(DBRS(DBRS,2))
- QUIT
- +107 ;
- +108 ; POST exists, PRE does not, adding a new record
- +109 ; Post DBRS action may be Delete
- +110 IF $DATA(DBRS(DBRS,2))
- IF '$DATA(DBRS(DBRS,1))
- Begin DoDot:2
- +111 IF HLACT="D"
- QUIT
- +112 SET INC=INC+1
- SET DIEN="+"_INC_","_DGIENS
- +113 SET DGFDA(26.131,DIEN,.01)=DBRS
- +114 SET X=DBRS(DBRS,2,"OTHER")
- if $LENGTH(X)
- SET DGFDA(26.131,DIEN,.02)=X
- +115 SET X=DBRS(DBRS,2,"DATE")
- if +X
- SET DGFDA(26.131,DIEN,.03)=X
- +116 SET X=DBRS(DBRS,2,"SITE")
- if +X
- SET DGFDA(26.131,DIEN,.04)=X
- +117 QUIT
- End DoDot:2
- QUIT
- +118 ;
- +119 ; Both PRE and POST exists, update existing record
- +120 ; conditional update of fields .03,.04
- +121 IF HLACT="D"
- SET DGFDA(26.131,IENS,.01)="@"
- QUIT
- +122 KILL DGFDA(26.131,IENS,.01)
- +123 SET X=$GET(DBRS(DBRS,1,"OTHER"))
- SET Y=$GET(DBRS(DBRS,2,"OTHER"))
- Begin DoDot:2
- +124 IF X'=Y
- SET DGFDA(26.131,IENS,.02)=Y
- +125 QUIT
- End DoDot:2
- +126 SET X=$GET(DBRS(DBRS,1,"DATE"))
- SET Y=$GET(DBRS(DBRS,2,"DATE"))
- Begin DoDot:2
- +127 IF $SELECT((ACT=7)!(ACT=8):1,+X:0,1:+Y)
- SET DGFDA(26.131,IENS,.03)=Y
- +128 QUIT
- End DoDot:2
- +129 SET X=$GET(DBRS(DBRS,1,"SITE"))
- SET Y=$GET(DBRS(DBRS,2,"SITE"))
- Begin DoDot:2
- +130 IF $SELECT((ACT=7)!(ACT=8):1,+X:0,1:+Y)
- SET DGFDA(26.131,IENS,.04)=Y
- +131 QUIT
- End DoDot:2
- +132 QUIT
- End DoDot:1
- +133 QUIT
- +134 ;
- +135 ;=====================================================================
- DEL(DGXIEN,DGFILE) ;
- +1 ; delete all DBRS records for a flag assignment or history record
- +2 ; QA on input values done in DGPFUT6
- +3 if '$GET(DGXIEN)
- QUIT
- if '$GET(DGFILE)
- QUIT
- +4 SET DGXIEN=+DGXIEN
- +5 if '$ORDER(^DGPF(DGFILE,DGXIEN,2,0))
- QUIT
- +6 if "^26.13^26.14^"'[(U_DGFILE_U)
- QUIT
- +7 NEW X,Y,DA,DGDBRSE,DIK
- +8 ; not need but cya, DEL node on ^DD(26.131,.01)
- SET DGDBRSE=1
- +9 SET DIK="^DGPF("_DGFILE_","_DGXIEN_",2,"
- SET DA(1)=DGIEN
- +10 SET DA=0
- FOR
- SET DA=$ORDER(^DGPF(DGFILE,DGXIEN,2,DA))
- if 'DA
- QUIT
- DO ^DIK
- +11 QUIT
- +12 ;
- +13 ;=====================================================================
- GETDBRS(DGRET,DGAIEN) ;
- +1 ;Return all DBRS data associated with a CAT I BEHAVIORAL assignment
- +2 ;INPUT PARAMETER: DGPFIEN - req - file_26.13_ien
- +3 ;RETURN VALUES:
- +4 ; .DGRET(0) = total number of DBRS records [0,1,2,...]
- +5 ; .DGRET(dbrs#) = <26.131_ien>,<26.13_ien>, [iens]
- +6 ; (dbrs#,"DBRS#") = internal^external [#.01]
- +7 ; (dbrs#,"OTHER") = internal^external [#.02]
- +8 ; (dbrs#,"DATE") = internal^external [#.03]
- +9 ; (dbrs#,"SITE") = internal^external [#.04]
- +10 ;
- +11 NEW X,Y,DGARR,DGIEN,DGERR,DIERR,IENS
- +12 SET DGRET(0)=0
- +13 SET DGAIEN=$GET(DGAIEN)
- if $EXTRACT(DGAIEN)="+"
- QUIT
- if 'DGAIEN
- QUIT
- +14 ;
- +15 SET DGIEN=(+DGAIEN)_","
- +16 DO GETS^DIQ(26.13,DGIEN,".02;2*","IE","DGARR","DGERR")
- +17 if $DATA(DIERR)
- QUIT
- +18 if DGARR(26.13,DGIEN,.02,"I")'[26.15
- QUIT
- +19 if DGARR(26.13,DGIEN,.02,"E")'="BEHAVIORAL"
- QUIT
- +20 SET IENS=0
- FOR
- SET IENS=$ORDER(DGARR(26.131,IENS))
- if 'IENS
- QUIT
- Begin DoDot:1
- +21 NEW DBRS,TMP
- MERGE TMP=DGARR(26.131,IENS)
- +22 SET DBRS=TMP(.01,"E")
- +23 SET DGRET(0)=1+DGRET(0)
- +24 SET DGRET(DBRS)=IENS
- +25 SET DGRET(DBRS,"DBRS#")=TMP(.01,"I")_U_TMP(.01,"E")
- +26 SET DGRET(DBRS,"OTHER")=TMP(.02,"I")_U_TMP(.02,"E")
- +27 SET DGRET(DBRS,"DATE")=TMP(.03,"I")_U_TMP(.03,"E")
- +28 SET DGRET(DBRS,"SITE")=TMP(.04,"I")_U_TMP(.04,"E")
- +29 QUIT
- End DoDot:1
- +30 QUIT
- +31 ;
- +32 ;=====================================================================
- GETDBRSH(DGRET,DGHIEN) ;
- +1 ; Get DBRS data for a History record
- +2 ;INPUT PARAMETERS: DGPFIEN - req - ien to file 26.14
- +3 ;RETURN VALUES:
- +4 ; .DGRET(0) = total number of DBRS records
- +5 ; .DGRET(dbrs#) = <26.142_ien>,<26.14_ien>, [iens]
- +6 ; (dbrs#,"DBRS#") = internal^external [#.01]
- +7 ; (dbrs#,"OTHER") = internal^external [#.02]
- +8 ; (dbrs#,"DATE") = internal^external [#.03]
- +9 ; (dbrs#,"STAT") = internal^external [#.04]
- +10 ; (dbrs#,"SITE") = internal^external [#.05]
- +11 ;
- +12 SET DGRET(0)=0
- +13 SET DGHIEN=$GET(DGHIEN)
- +14 IF DGHIEN
- IF $DATA(^DGPF(26.14,DGHIEN,2))
- Begin DoDot:1
- +15 NEW DGARR,DGERR,DIERR,IEN,IENS
- +16 SET IENS=(+DGHIEN)_","
- +17 DO GETS^DIQ(26.14,IENS,"2*","IE","DGARR","DGERR")
- +18 if $DATA(DIERR)
- QUIT
- +19 SET IEN=0
- FOR
- SET IEN=$ORDER(DGARR(26.142,IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +20 NEW DBRS,TMP
- +21 MERGE TMP=DGARR(26.142,IEN)
- +22 SET DBRS=TMP(.01,"E")
- +23 SET DGRET(0)=1+DGRET(0)
- +24 SET DGRET(DBRS)=IEN
- +25 SET DGRET(DBRS,"DBRS#")=TMP(.01,"I")_U_TMP(.01,"E")
- +26 SET DGRET(DBRS,"OTHER")=TMP(.02,"I")_U_TMP(.02,"E")
- +27 SET DGRET(DBRS,"DATE")=TMP(.03,"I")_U_$PIECE(TMP(.03,"E"),":",1,2)
- +28 SET DGRET(DBRS,"STAT")=TMP(.04,"I")_U_TMP(.04,"E")
- +29 SET DGRET(DBRS,"SITE")=TMP(.05,"I")_U_TMP(.05,"E")
- +30 QUIT
- End DoDot:2
- +31 QUIT
- End DoDot:1
- +32 QUIT
- +33 ;
- +34 ;=====================================================================
- STOHIST(DGIENS,DGFLD,DGFDA,DGPFERR) ;
- +1 ; Set up FDA() for use in UPDATE^DIE
- +2 ; For more information on input params, see STOHIST^DGPFAAH
- +3 ;INPUT PARAMETERS:
- +4 ; DGIENS - req - fda() iens to file 26.14, may be "+1,"
- +5 ; .DGFLD - req - subset of DGPFAH()
- +6 ;RETURN PARAMETERS:
- +7 ; .DGFDA - FDA array of UPDATE^DIE
- +8 ; DGFDA() may have existing nodes unrelated to DBRS
- +9 ; .DGPFERR - error array to return to calling program
- +10 ;
- +11 NEW I,J,IEN,INC
- +12 SET DGIENS=$GET(DGIENS)
- IF DGIENS=""
- QUIT
- +13 IF $EXTRACT(DGIENS)'="+"
- IF '$DATA(^DGPF(26.14,+DGIENS,0))
- QUIT
- +14 if '$DATA(DGFLD("DBRS"))
- QUIT
- +15 ;
- +16 SET INC=50
- SET I=0
- FOR J=0:0
- SET I=$ORDER(DGFLD("DBRS",I))
- if 'I
- QUIT
- Begin DoDot:1
- +17 NEW J,IENS,INP
- +18 ; expects DGFLD("DBRS",I) to consist of 5 single valued pieces
- +19 FOR J=1:1:5
- SET INP(J)=$PIECE(DGFLD("DBRS",I),U,J)
- +20 SET INC=INC+1
- SET IENS="+"_INC_","_DGIENS
- +21 ; DBRS#
- SET DGFDA(26.142,IENS,.01)=INP(1)
- +22 ; OTHER
- IF $LENGTH(INP(2))
- SET DGFDA(26.142,IENS,.02)=INP(2)
- +23 ; DATE
- IF +INP(3)
- SET DGFDA(26.142,IENS,.03)=INP(3)
- +24 ; STAT
- IF INP(4)?1U
- SET DGFDA(26.142,IENS,.04)=INP(4)
- +25 ; SITE
- IF +INP(5)
- SET DGFDA(26.142,IENS,.05)=INP(5)
- +26 QUIT
- End DoDot:1
- +27 QUIT