DGROHLR1 ;GTS/PHH,TDM - ROM HL7 RECEIVE DRIVERS ; 6/26/13 2:37pm
;;5.3;Registration;**572,622,647,809,754,797,897**;Aug 13, 1993;Build 10
;
CONVFDA(DFN,DGDATA) ; LOOP THROUGH DATA TO FILE
N DFNC,F,IEN,FIELD,DGROAR,FNUM,QVAR,INX,DGRONUPD
;
;*DGROAR: Indirect reference to DGROAYi where "i" is the ORDER INDEX
;* field value in 391.23. ORDER INDEX defines order for a group of
;* fields loaded into the LST.
;* DGROAYi defined for each group maintaining proper order.
;* DG*5.3*572
;* DGRONUPD flag used to suppress updating the 'CHANGE DT/TM' &
;* 'CHANGE SITE' fields for CONF & TEMP address data.
;
S DFNC=DFN_","
S INX=""
S DGRONUPD=1
F S INX=$O(^DGRO(391.23,"D",INX)) Q:INX="" D
. S DGROAR="DGROAY"_INX
. S QVAR=0
. S F=""
. F S F=$O(@DGDATA@(F)) Q:F="" D
. . S IEN=""
. . F S IEN=$O(@DGDATA@(F,IEN)) Q:IEN="" D
. . . S FIELD=""
. . . F S FIELD=$O(@DGDATA@(F,IEN,FIELD)) Q:FIELD="" D
. . . . Q:$$DIS(F,FIELD)
. . . . S ORDINX=$O(^DGRO(391.23,"E",F,FIELD,""))
. . . . D:(ORDINX=INX) SETARY
. . . . ;* Following line files Internal PEC, Rmv once Ext PEC is filed
. . . . I (ORDINX=INX)&(F=2) DO
. . . . .D:(FIELD=.1417) FILECSTD
. . . . .D:(FIELD=.361) FILEPEC
. . . . .D:((FIELD=.117)!(FIELD=.12111)!(FIELD=.14111)) FILECNTY
. . I (+$O(@DGROAR@(""))>0) S QVAR=1 D FILE
Q
;
FILECSTD ;File CONFIDENTIAL START DATE bypassing FM restrictions
;Called from CONVFDA^DGROHLR1
I $D(@DGROAR@(F,DFNC,FIELD)) D
. S X=@DGROAR@(F,DFNC,FIELD)
. S %DT="X" D ^%DT I Y D
. . S DGROCST(F,DFNC,FIELD)=Y
. . D FILE^DIE("U","DGROCST","ERR")
. K @DGROAR@(F,DFNC,FIELD)
. K DGROCST,X,%DT,Y
Q
;
FILECNTY ;*Retrieve county IEN and file county
;*Retrieve State IEN corresponding to Temp, Conf, or Perm State
I (FIELD=.117),($D(^DPT(DFN,.11))) S STATEIEN=$P(^DPT(DFN,.11),"^",5)
I (FIELD=.12111),($D(^DPT(DFN,.121))) S STATEIEN=$P(^DPT(DFN,.121),"^",5)
I (FIELD=.14111),($D(^DPT(DFN,.141))) S STATEIEN=$P(^DPT(DFN,.141),"^",5)
;
;*Retrieve County IEN for exact county returned from LST
; DG*647
I $G(STATEIEN)="" G NOCNTY
I '$D(@DGROAR@(F,DFNC,FIELD)) G NOCNTY
S DIC="^DIC(5,"_STATEIEN_",1,"
S DIC(0)="XS"
S X=@DGROAR@(F,DFNC,FIELD)
D ^DIC
S DGROCTY(F,DFNC,FIELD)=+Y
D FILE^DIE("","DGROCTY","ERR") ;File County IEN
NOCNTY K @DGROAR@(F,DFNC,FIELD)
K STATEIEN,DGROCTY
Q
;
FILEPEC ;File Internal value of Prim Elig Code
;Called from CONVFDA^DGROHLR1
;Remove this call when fields required by PEC are received
; from LST
I $D(@DGROAR@(F,DFNC,FIELD)) DO
. S DIC="^DIC(8,"
. S DIC(0)="MNSX"
. S X=@DGROAR@(F,DFNC,FIELD)
. D ^DIC
. S DGROPEC(F,DFNC,FIELD)=+Y
. D FILE^DIE("","DGROPEC","ERR")
. K @DGROAR@(F,DFNC,FIELD)
. K DGROPEC,DIC,X
Q
;
FILE ;*Execute FILE or UPDATE per FNUM (1st subscpt) for file # according
;* to file/multiple record add or adding existing Patient data add
S FNUM=$O(@DGROAR@(""))
K %DT ;* Clean up leaks from Input transforms that set %DT(0)
;
;* Patient file processing
I +FNUM=2 DO
. D FILE^DIE("E","@DGROAR","ERR") ;*Add to existing Patient entry
;
;* Patient file multiples processing
I (+FNUM=2.01)!(+FNUM=2.141)!(+FNUM=2.11) DO
. D UPDATE^DIE("E","@DGROAR","","ERR")
I +FNUM=2.3216 D
. D CONVERT ;Convert MSE fields to internal format
. D UPDATE^DIE("","@DGROAR","","ERR")
I (+FNUM=2.02)!(+FNUM=2.06) DO
. N DGRODNUM,DGIEN,DNUMDATA,DGIEN2,DGROIEN,DGFLD
. S DGRODNUM=0
. F S DGRODNUM=$O(@DGROAR@(+FNUM,DGRODNUM)) Q:DGRODNUM="" D
. . S DGIEN=$P(DGRODNUM,",")
. . I DGIEN S DGIEN2=$P(DGIEN,"+",2)
. . S DNUMDATA=$G(@DGROAR@(+FNUM,DGRODNUM,.01))
. . ; Changed FileMan call for processing of DINUM recs DG*5.3*897
. . ; I DGIEN2 S DGROIEN(DGIEN2)=DNUMDATA D
. . ; . D UPDATE^DIE("","@DGROAR","DGROIEN","ERR") ;*Converted Ext to Int
. . I DGIEN2 S DGROIEN(DGIEN2)=DNUMDATA
. . S DGFLD="."_$P(FNUM,".",2) D
. . . S (X,DINUM)=DNUMDATA,DIC="^DPT(DFN,DGFLD,",DA(1)=DFN,DIC(0)="L"
. . . K DO D FILE^DICN K DIC,X,DINUM,DA
;
;* Processing fields [indicated in 391.23] not part of Patient file.
;* Define IF section for each file not a Patient file field or
;* Multiple.
I (+$P(FNUM,".")'=2) DO
. I +FNUM=38.1 DO
. . N DGROARBI
. . S DGROARBI(1)=DFN ;*Set 38.1 IEN to DFN
. . D UPDATE^DIE("E","@DGROAR","DGROARBI","ERR")
;
K @DGROAR
Q
;
SETARY ;* Setup arrays of data to be filed
N U,D,DATA,NODE,NODE2,INENNUM
;
I '$D(^DGRO(391.23,"C",F,FIELD)) Q
;
S U="^"
;
;CHECK LOCAL PATIENT FILE FOR EXISTING DATA, DO NOT OVERWRITE
S D=$$GET1^DIQ(F,DFNC,FIELD)
I D'="" K @DGDATA@(F,IEN,FIELD) Q
;
S DATA=$G(@DGDATA@(F,IEN,FIELD,"E"))
Q:DATA=""
;
;* Design of this Subroutine:
;* Set array defining groups of date for Fileman filing in
;* a predefined order.
;* Indirection defined various array names for different ordered
;* data groups in CONVFDA.
;* File Ext. values returned from LST per ORDER INDEX.
;* DG*5.3*572
;
;* Get field entry IEN in ROM 391.23 file
S INENNUM=INX
;
I F=2 DO Q
. S @DGROAR@(F,DFNC,FIELD)=DATA ;*Indirection to Patient Array
. K @DGDATA@(F,IEN,FIELD)
;
;* Set array for all other files (not Patient or Security files)
;* This section is for new entries in files. Not for Multiples.
;* Code to process specific files needed in CONVFDA
I (+$P(F,".")'=2),(F'=38.1) DO Q
. S @DGROAR@(F,"+1,",FIELD)=DATA
. K @DGDATA@(F,IEN,FIELD)
;
;SET ALIAS, CONFIDENTIAL ADDRESS CAT. AND MILITARY SERVICE EPISODE
;SUBFILE ARRAYS
I (F=2.01)!(F=2.141)!(F=2.11)!(F=2.3216) D Q
. S NODE2="+"
. S NODE2=NODE2_$P(IEN,",")_","_DFNC
. S @DGROAR@(F,NODE2,FIELD)=DATA ;*Indirection to Patient Array
. K @DGDATA@(F,IEN,FIELD)
;
;SET RACE AND ETHNICITY ARRAYS
I (F=2.02)!(F=2.06) D Q
. N REFILE,REIEN,DATA30,QFL,DATACOMP,TEST,ERR,INACTIVE
. I (F=2.02),(FIELD=.01) S REFILE=10
. I (F=2.06),(FIELD=.01) S REFILE=10.2
. I FIELD=.02 S REFILE=10.3
. S DATA30=$E(DATA,1,30) D
. . S QFL=0,REIEN="",NODE=""
. . D FIND^DIC(REFILE,"","@;.01;200","",DATA30,,"B","","","TEST","ERR")
. . F S NODE=$O(TEST("DILIST",2,NODE)) Q:'NODE D Q:$G(QFL)=1
. . . S REIEN=$G(TEST("DILIST",2,NODE))
. . . S INACTIVE=$G(TEST("DILIST","ID",NODE,200))
. . . Q:INACTIVE="YES" ;* QUIT if Race or Eth Inact
. . . S DATACOMP=$G(TEST("DILIST","ID",NODE,.01))
. . . I DATACOMP=DATA S QFL=1
. Q:'QFL
. Q:$G(INACTIVE)="YES" ;* No entry for Inactive Race/Ethncty
. S DATA=REIEN ;*Race/Ethncty/MOC (10/10.2/10.3) IEN for data recvd
. ;
. S NODE2="+" ;*+ for all fields, All fields added in one UPDATE
. S NODE2=NODE2_$P(IEN,",")_","_DFNC ;*No + for DFNC, DPT record exists
. S @DGROAR@(F,NODE2,FIELD)=DATA ;*Indirection to Patient Array
. K @DGDATA@(F,IEN,FIELD)
;
;* Set all sensitive fields (38.1) in array
I F=38.1 D Q
. Q:('$D(@DGDATA@(F))) ;*Data already filed
. S FIELD=.01
. S @DGROAR@(F,"+1,",FIELD)=$$GET1^DIQ(2,DFN,.01)
. F S FIELD=$O(@DGDATA@(F,IEN,FIELD)) Q:'FIELD D
. . S @DGROAR@(F,"+1,",FIELD)=@DGDATA@(F,IEN,FIELD,"E")
. K @DGDATA@(F,IEN)
. S FIELD=999999 ;*Skip to end of 38.1 field list in @DGDATA
Q
;
DIS(F,FIELD) ;Check for disabled
N SUB S SUB=$O(^DGRO(391.23,"C",F,FIELD,0)) Q:'SUB 1
I $P($G(^DGRO(391.23,SUB,0)),"^",5)=1 Q 1
Q 0
;
CONVERT ;External to Internal Conversion (clears field if no match found)
N BOS,DATE,COMP,DISCH,F,INTERNAL,LOCK,SUB,X,Y
S F=2.3216,SUB=""
F S SUB=$O(@DGROAR@(F,SUB)) Q:SUB="" D
.;Convert Branch
.I $D(@DGROAR@(F,SUB,.03)) D
..S BOS=$G(@DGROAR@(F,SUB,.03)) Q:BOS=""
..S INTERNAL=$O(^DIC(23,"B",BOS,""))
..S @DGROAR@(F,SUB,.03)=INTERNAL
.;Convert Discharge
.I $D(@DGROAR@(F,SUB,.06)) D
..S DISCH=$G(@DGROAR@(F,SUB,.06)) Q:DISCH=""
..S INTERNAL=$O(^DIC(25,"B",DISCH,""))
..S @DGROAR@(F,SUB,.06)=INTERNAL
.;Convert Component
.I $D(@DGROAR@(F,SUB,.04)) D
..S COMP=$G(@DGROAR@(F,SUB,.04)) Q:COMP=""
..S INTERNAL=""
..S:COMP="REGULAR" INTERNAL="R"
..S:COMP="ACTIVATED NG" INTERNAL="G"
..S:COMP="ACTIVATED RESERVE" INTERNAL="V"
..S @DGROAR@(F,SUB,.04)=INTERNAL
.;Convert Lock flag
.I $D(@DGROAR@(F,SUB,.07)) D
..S LOCK=$G(@DGROAR@(F,SUB,.07)) Q:LOCK=""
..S INTERNAL=$S(LOCK="YES":1,LOCK="NO":0,1:"")
..S @DGROAR@(F,SUB,.07)=INTERNAL
.;Convert dates
.I $D(@DGROAR@(F,SUB,.01)) D
..S X=$G(@DGROAR@(F,SUB,.01)) Q:X=""
..D ^%DT
..S @DGROAR@(F,SUB,.01)=Y
.I $D(@DGROAR@(F,SUB,.02)) D
..S X=$G(@DGROAR@(F,SUB,.02)) Q:X=""
..D ^%DT
..S @DGROAR@(F,SUB,.02)=Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGROHLR1 8552 printed Mar 13, 2025@21:59:59 Page 2
DGROHLR1 ;GTS/PHH,TDM - ROM HL7 RECEIVE DRIVERS ; 6/26/13 2:37pm
+1 ;;5.3;Registration;**572,622,647,809,754,797,897**;Aug 13, 1993;Build 10
+2 ;
CONVFDA(DFN,DGDATA) ; LOOP THROUGH DATA TO FILE
+1 NEW DFNC,F,IEN,FIELD,DGROAR,FNUM,QVAR,INX,DGRONUPD
+2 ;
+3 ;*DGROAR: Indirect reference to DGROAYi where "i" is the ORDER INDEX
+4 ;* field value in 391.23. ORDER INDEX defines order for a group of
+5 ;* fields loaded into the LST.
+6 ;* DGROAYi defined for each group maintaining proper order.
+7 ;* DG*5.3*572
+8 ;* DGRONUPD flag used to suppress updating the 'CHANGE DT/TM' &
+9 ;* 'CHANGE SITE' fields for CONF & TEMP address data.
+10 ;
+11 SET DFNC=DFN_","
+12 SET INX=""
+13 SET DGRONUPD=1
+14 FOR
SET INX=$ORDER(^DGRO(391.23,"D",INX))
if INX=""
QUIT
Begin DoDot:1
+15 SET DGROAR="DGROAY"_INX
+16 SET QVAR=0
+17 SET F=""
+18 FOR
SET F=$ORDER(@DGDATA@(F))
if F=""
QUIT
Begin DoDot:2
+19 SET IEN=""
+20 FOR
SET IEN=$ORDER(@DGDATA@(F,IEN))
if IEN=""
QUIT
Begin DoDot:3
+21 SET FIELD=""
+22 FOR
SET FIELD=$ORDER(@DGDATA@(F,IEN,FIELD))
if FIELD=""
QUIT
Begin DoDot:4
+23 if $$DIS(F,FIELD)
QUIT
+24 SET ORDINX=$ORDER(^DGRO(391.23,"E",F,FIELD,""))
+25 if (ORDINX=INX)
DO SETARY
+26 ;* Following line files Internal PEC, Rmv once Ext PEC is filed
+27 IF (ORDINX=INX)&(F=2)
Begin DoDot:5
+28 if (FIELD=.1417)
DO FILECSTD
+29 if (FIELD=.361)
DO FILEPEC
+30 if ((FIELD=.117)!(FIELD=.12111)!(FIELD=.14111))
DO FILECNTY
End DoDot:5
End DoDot:4
End DoDot:3
+31 IF (+$ORDER(@DGROAR@(""))>0)
SET QVAR=1
DO FILE
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
FILECSTD ;File CONFIDENTIAL START DATE bypassing FM restrictions
+1 ;Called from CONVFDA^DGROHLR1
+2 IF $DATA(@DGROAR@(F,DFNC,FIELD))
Begin DoDot:1
+3 SET X=@DGROAR@(F,DFNC,FIELD)
+4 SET %DT="X"
DO ^%DT
IF Y
Begin DoDot:2
+5 SET DGROCST(F,DFNC,FIELD)=Y
+6 DO FILE^DIE("U","DGROCST","ERR")
End DoDot:2
+7 KILL @DGROAR@(F,DFNC,FIELD)
+8 KILL DGROCST,X,%DT,Y
End DoDot:1
+9 QUIT
+10 ;
FILECNTY ;*Retrieve county IEN and file county
+1 ;*Retrieve State IEN corresponding to Temp, Conf, or Perm State
+2 IF (FIELD=.117)
IF ($DATA(^DPT(DFN,.11)))
SET STATEIEN=$PIECE(^DPT(DFN,.11),"^",5)
+3 IF (FIELD=.12111)
IF ($DATA(^DPT(DFN,.121)))
SET STATEIEN=$PIECE(^DPT(DFN,.121),"^",5)
+4 IF (FIELD=.14111)
IF ($DATA(^DPT(DFN,.141)))
SET STATEIEN=$PIECE(^DPT(DFN,.141),"^",5)
+5 ;
+6 ;*Retrieve County IEN for exact county returned from LST
+7 ; DG*647
+8 IF $GET(STATEIEN)=""
GOTO NOCNTY
+9 IF '$DATA(@DGROAR@(F,DFNC,FIELD))
GOTO NOCNTY
+10 SET DIC="^DIC(5,"_STATEIEN_",1,"
+11 SET DIC(0)="XS"
+12 SET X=@DGROAR@(F,DFNC,FIELD)
+13 DO ^DIC
+14 SET DGROCTY(F,DFNC,FIELD)=+Y
+15 ;File County IEN
DO FILE^DIE("","DGROCTY","ERR")
NOCNTY KILL @DGROAR@(F,DFNC,FIELD)
+1 KILL STATEIEN,DGROCTY
+2 QUIT
+3 ;
FILEPEC ;File Internal value of Prim Elig Code
+1 ;Called from CONVFDA^DGROHLR1
+2 ;Remove this call when fields required by PEC are received
+3 ; from LST
+4 IF $DATA(@DGROAR@(F,DFNC,FIELD))
Begin DoDot:1
+5 SET DIC="^DIC(8,"
+6 SET DIC(0)="MNSX"
+7 SET X=@DGROAR@(F,DFNC,FIELD)
+8 DO ^DIC
+9 SET DGROPEC(F,DFNC,FIELD)=+Y
+10 DO FILE^DIE("","DGROPEC","ERR")
+11 KILL @DGROAR@(F,DFNC,FIELD)
+12 KILL DGROPEC,DIC,X
End DoDot:1
+13 QUIT
+14 ;
FILE ;*Execute FILE or UPDATE per FNUM (1st subscpt) for file # according
+1 ;* to file/multiple record add or adding existing Patient data add
+2 SET FNUM=$ORDER(@DGROAR@(""))
+3 ;* Clean up leaks from Input transforms that set %DT(0)
KILL %DT
+4 ;
+5 ;* Patient file processing
+6 IF +FNUM=2
Begin DoDot:1
+7 ;*Add to existing Patient entry
DO FILE^DIE("E","@DGROAR","ERR")
End DoDot:1
+8 ;
+9 ;* Patient file multiples processing
+10 IF (+FNUM=2.01)!(+FNUM=2.141)!(+FNUM=2.11)
Begin DoDot:1
+11 DO UPDATE^DIE("E","@DGROAR","","ERR")
End DoDot:1
+12 IF +FNUM=2.3216
Begin DoDot:1
+13 ;Convert MSE fields to internal format
DO CONVERT
+14 DO UPDATE^DIE("","@DGROAR","","ERR")
End DoDot:1
+15 IF (+FNUM=2.02)!(+FNUM=2.06)
Begin DoDot:1
+16 NEW DGRODNUM,DGIEN,DNUMDATA,DGIEN2,DGROIEN,DGFLD
+17 SET DGRODNUM=0
+18 FOR
SET DGRODNUM=$ORDER(@DGROAR@(+FNUM,DGRODNUM))
if DGRODNUM=""
QUIT
Begin DoDot:2
+19 SET DGIEN=$PIECE(DGRODNUM,",")
+20 IF DGIEN
SET DGIEN2=$PIECE(DGIEN,"+",2)
+21 SET DNUMDATA=$GET(@DGROAR@(+FNUM,DGRODNUM,.01))
+22 ; Changed FileMan call for processing of DINUM recs DG*5.3*897
+23 ; I DGIEN2 S DGROIEN(DGIEN2)=DNUMDATA D
+24 ; . D UPDATE^DIE("","@DGROAR","DGROIEN","ERR") ;*Converted Ext to Int
+25 IF DGIEN2
SET DGROIEN(DGIEN2)=DNUMDATA
+26 SET DGFLD="."_$PIECE(FNUM,".",2)
Begin DoDot:3
+27 SET (X,DINUM)=DNUMDATA
SET DIC="^DPT(DFN,DGFLD,"
SET DA(1)=DFN
SET DIC(0)="L"
+28 KILL DO
DO FILE^DICN
KILL DIC,X,DINUM,DA
End DoDot:3
End DoDot:2
End DoDot:1
+29 ;
+30 ;* Processing fields [indicated in 391.23] not part of Patient file.
+31 ;* Define IF section for each file not a Patient file field or
+32 ;* Multiple.
+33 IF (+$PIECE(FNUM,".")'=2)
Begin DoDot:1
+34 IF +FNUM=38.1
Begin DoDot:2
+35 NEW DGROARBI
+36 ;*Set 38.1 IEN to DFN
SET DGROARBI(1)=DFN
+37 DO UPDATE^DIE("E","@DGROAR","DGROARBI","ERR")
End DoDot:2
End DoDot:1
+38 ;
+39 KILL @DGROAR
+40 QUIT
+41 ;
SETARY ;* Setup arrays of data to be filed
+1 NEW U,D,DATA,NODE,NODE2,INENNUM
+2 ;
+3 IF '$DATA(^DGRO(391.23,"C",F,FIELD))
QUIT
+4 ;
+5 SET U="^"
+6 ;
+7 ;CHECK LOCAL PATIENT FILE FOR EXISTING DATA, DO NOT OVERWRITE
+8 SET D=$$GET1^DIQ(F,DFNC,FIELD)
+9 IF D'=""
KILL @DGDATA@(F,IEN,FIELD)
QUIT
+10 ;
+11 SET DATA=$GET(@DGDATA@(F,IEN,FIELD,"E"))
+12 if DATA=""
QUIT
+13 ;
+14 ;* Design of this Subroutine:
+15 ;* Set array defining groups of date for Fileman filing in
+16 ;* a predefined order.
+17 ;* Indirection defined various array names for different ordered
+18 ;* data groups in CONVFDA.
+19 ;* File Ext. values returned from LST per ORDER INDEX.
+20 ;* DG*5.3*572
+21 ;
+22 ;* Get field entry IEN in ROM 391.23 file
+23 SET INENNUM=INX
+24 ;
+25 IF F=2
Begin DoDot:1
+26 ;*Indirection to Patient Array
SET @DGROAR@(F,DFNC,FIELD)=DATA
+27 KILL @DGDATA@(F,IEN,FIELD)
End DoDot:1
QUIT
+28 ;
+29 ;* Set array for all other files (not Patient or Security files)
+30 ;* This section is for new entries in files. Not for Multiples.
+31 ;* Code to process specific files needed in CONVFDA
+32 IF (+$PIECE(F,".")'=2)
IF (F'=38.1)
Begin DoDot:1
+33 SET @DGROAR@(F,"+1,",FIELD)=DATA
+34 KILL @DGDATA@(F,IEN,FIELD)
End DoDot:1
QUIT
+35 ;
+36 ;SET ALIAS, CONFIDENTIAL ADDRESS CAT. AND MILITARY SERVICE EPISODE
+37 ;SUBFILE ARRAYS
+38 IF (F=2.01)!(F=2.141)!(F=2.11)!(F=2.3216)
Begin DoDot:1
+39 SET NODE2="+"
+40 SET NODE2=NODE2_$PIECE(IEN,",")_","_DFNC
+41 ;*Indirection to Patient Array
SET @DGROAR@(F,NODE2,FIELD)=DATA
+42 KILL @DGDATA@(F,IEN,FIELD)
End DoDot:1
QUIT
+43 ;
+44 ;SET RACE AND ETHNICITY ARRAYS
+45 IF (F=2.02)!(F=2.06)
Begin DoDot:1
+46 NEW REFILE,REIEN,DATA30,QFL,DATACOMP,TEST,ERR,INACTIVE
+47 IF (F=2.02)
IF (FIELD=.01)
SET REFILE=10
+48 IF (F=2.06)
IF (FIELD=.01)
SET REFILE=10.2
+49 IF FIELD=.02
SET REFILE=10.3
+50 SET DATA30=$EXTRACT(DATA,1,30)
Begin DoDot:2
+51 SET QFL=0
SET REIEN=""
SET NODE=""
+52 DO FIND^DIC(REFILE,"","@;.01;200","",DATA30,,"B","","","TEST","ERR")
+53 FOR
SET NODE=$ORDER(TEST("DILIST",2,NODE))
if 'NODE
QUIT
Begin DoDot:3
+54 SET REIEN=$GET(TEST("DILIST",2,NODE))
+55 SET INACTIVE=$GET(TEST("DILIST","ID",NODE,200))
+56 ;* QUIT if Race or Eth Inact
if INACTIVE="YES"
QUIT
+57 SET DATACOMP=$GET(TEST("DILIST","ID",NODE,.01))
+58 IF DATACOMP=DATA
SET QFL=1
End DoDot:3
if $GET(QFL)=1
QUIT
End DoDot:2
+59 if 'QFL
QUIT
+60 ;* No entry for Inactive Race/Ethncty
if $GET(INACTIVE)="YES"
QUIT
+61 ;*Race/Ethncty/MOC (10/10.2/10.3) IEN for data recvd
SET DATA=REIEN
+62 ;
+63 ;*+ for all fields, All fields added in one UPDATE
SET NODE2="+"
+64 ;*No + for DFNC, DPT record exists
SET NODE2=NODE2_$PIECE(IEN,",")_","_DFNC
+65 ;*Indirection to Patient Array
SET @DGROAR@(F,NODE2,FIELD)=DATA
+66 KILL @DGDATA@(F,IEN,FIELD)
End DoDot:1
QUIT
+67 ;
+68 ;* Set all sensitive fields (38.1) in array
+69 IF F=38.1
Begin DoDot:1
+70 ;*Data already filed
if ('$DATA(@DGDATA@(F)))
QUIT
+71 SET FIELD=.01
+72 SET @DGROAR@(F,"+1,",FIELD)=$$GET1^DIQ(2,DFN,.01)
+73 FOR
SET FIELD=$ORDER(@DGDATA@(F,IEN,FIELD))
if 'FIELD
QUIT
Begin DoDot:2
+74 SET @DGROAR@(F,"+1,",FIELD)=@DGDATA@(F,IEN,FIELD,"E")
End DoDot:2
+75 KILL @DGDATA@(F,IEN)
+76 ;*Skip to end of 38.1 field list in @DGDATA
SET FIELD=999999
End DoDot:1
QUIT
+77 QUIT
+78 ;
DIS(F,FIELD) ;Check for disabled
+1 NEW SUB
SET SUB=$ORDER(^DGRO(391.23,"C",F,FIELD,0))
if 'SUB
QUIT 1
+2 IF $PIECE($GET(^DGRO(391.23,SUB,0)),"^",5)=1
QUIT 1
+3 QUIT 0
+4 ;
CONVERT ;External to Internal Conversion (clears field if no match found)
+1 NEW BOS,DATE,COMP,DISCH,F,INTERNAL,LOCK,SUB,X,Y
+2 SET F=2.3216
SET SUB=""
+3 FOR
SET SUB=$ORDER(@DGROAR@(F,SUB))
if SUB=""
QUIT
Begin DoDot:1
+4 ;Convert Branch
+5 IF $DATA(@DGROAR@(F,SUB,.03))
Begin DoDot:2
+6 SET BOS=$GET(@DGROAR@(F,SUB,.03))
if BOS=""
QUIT
+7 SET INTERNAL=$ORDER(^DIC(23,"B",BOS,""))
+8 SET @DGROAR@(F,SUB,.03)=INTERNAL
End DoDot:2
+9 ;Convert Discharge
+10 IF $DATA(@DGROAR@(F,SUB,.06))
Begin DoDot:2
+11 SET DISCH=$GET(@DGROAR@(F,SUB,.06))
if DISCH=""
QUIT
+12 SET INTERNAL=$ORDER(^DIC(25,"B",DISCH,""))
+13 SET @DGROAR@(F,SUB,.06)=INTERNAL
End DoDot:2
+14 ;Convert Component
+15 IF $DATA(@DGROAR@(F,SUB,.04))
Begin DoDot:2
+16 SET COMP=$GET(@DGROAR@(F,SUB,.04))
if COMP=""
QUIT
+17 SET INTERNAL=""
+18 if COMP="REGULAR"
SET INTERNAL="R"
+19 if COMP="ACTIVATED NG"
SET INTERNAL="G"
+20 if COMP="ACTIVATED RESERVE"
SET INTERNAL="V"
+21 SET @DGROAR@(F,SUB,.04)=INTERNAL
End DoDot:2
+22 ;Convert Lock flag
+23 IF $DATA(@DGROAR@(F,SUB,.07))
Begin DoDot:2
+24 SET LOCK=$GET(@DGROAR@(F,SUB,.07))
if LOCK=""
QUIT
+25 SET INTERNAL=$SELECT(LOCK="YES":1,LOCK="NO":0,1:"")
+26 SET @DGROAR@(F,SUB,.07)=INTERNAL
End DoDot:2
+27 ;Convert dates
+28 IF $DATA(@DGROAR@(F,SUB,.01))
Begin DoDot:2
+29 SET X=$GET(@DGROAR@(F,SUB,.01))
if X=""
QUIT
+30 DO ^%DT
+31 SET @DGROAR@(F,SUB,.01)=Y
End DoDot:2
+32 IF $DATA(@DGROAR@(F,SUB,.02))
Begin DoDot:2
+33 SET X=$GET(@DGROAR@(F,SUB,.02))
if X=""
QUIT
+34 DO ^%DT
+35 SET @DGROAR@(F,SUB,.02)=Y
End DoDot:2
End DoDot:1
+36 QUIT
