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 Apr 09, 2024@21:38:56 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
