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

DGROHLR1.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. CONVFDA(DFN,DGDATA) ; LOOP THROUGH DATA TO FILE
  1.  N DFNC,F,IEN,FIELD,DGROAR,FNUM,QVAR,INX,DGRONUPD
  1.  ;
  1.  ;*DGROAR: Indirect reference to DGROAYi where "i" is the ORDER INDEX
  1.  ;* field value in 391.23.  ORDER INDEX defines order for a group of
  1.  ;* fields loaded into the LST.
  1.  ;* DGROAYi defined for each group maintaining proper order.
  1.  ;*  DG*5.3*572
  1.  ;* DGRONUPD flag used to suppress updating the 'CHANGE DT/TM' &
  1.  ;*          'CHANGE SITE' fields for CONF & TEMP address data.
  1.  ;
  1.  S DFNC=DFN_","
  1.  S INX=""
  1.  S DGRONUPD=1
  1.  F  S INX=$O(^DGRO(391.23,"D",INX)) Q:INX=""  D
  1.  . S DGROAR="DGROAY"_INX
  1.  . S QVAR=0
  1.  . S F=""
  1.  . F  S F=$O(@DGDATA@(F)) Q:F=""  D
  1.  . . S IEN=""
  1.  . . F  S IEN=$O(@DGDATA@(F,IEN)) Q:IEN=""  D
  1.  . . . S FIELD=""
  1.  . . . F  S FIELD=$O(@DGDATA@(F,IEN,FIELD)) Q:FIELD=""  D
  1.  . . . . Q:$$DIS(F,FIELD)
  1.  . . . . S ORDINX=$O(^DGRO(391.23,"E",F,FIELD,""))
  1.  . . . . D:(ORDINX=INX) SETARY
  1.  . . . . ;* Following line files Internal PEC, Rmv once Ext PEC is filed
  1.  . . . . I (ORDINX=INX)&(F=2) DO
  1.  . . . . .D:(FIELD=.1417) FILECSTD
  1.  . . . . .D:(FIELD=.361) FILEPEC
  1.  . . . . .D:((FIELD=.117)!(FIELD=.12111)!(FIELD=.14111)) FILECNTY
  1.  . . I (+$O(@DGROAR@(""))>0) S QVAR=1 D FILE
  1.  Q
  1.  ;
  1. FILECSTD ;File CONFIDENTIAL START DATE bypassing FM restrictions
  1.  ;Called from CONVFDA^DGROHLR1
  1.  I $D(@DGROAR@(F,DFNC,FIELD)) D
  1.  . S X=@DGROAR@(F,DFNC,FIELD)
  1.  . S %DT="X" D ^%DT I Y D
  1.  . . S DGROCST(F,DFNC,FIELD)=Y
  1.  . . D FILE^DIE("U","DGROCST","ERR")
  1.  . K @DGROAR@(F,DFNC,FIELD)
  1.  . K DGROCST,X,%DT,Y
  1.  Q
  1.  ;
  1. FILECNTY ;*Retrieve county IEN and file county
  1.  ;*Retrieve State IEN corresponding to Temp, Conf, or Perm State
  1.  I (FIELD=.117),($D(^DPT(DFN,.11))) S STATEIEN=$P(^DPT(DFN,.11),"^",5)
  1.  I (FIELD=.12111),($D(^DPT(DFN,.121))) S STATEIEN=$P(^DPT(DFN,.121),"^",5)
  1.  I (FIELD=.14111),($D(^DPT(DFN,.141))) S STATEIEN=$P(^DPT(DFN,.141),"^",5)
  1.  ;
  1.  ;*Retrieve County IEN for exact county returned from LST
  1.  ; DG*647
  1.  I $G(STATEIEN)="" G NOCNTY
  1.  I '$D(@DGROAR@(F,DFNC,FIELD)) G NOCNTY
  1.  S DIC="^DIC(5,"_STATEIEN_",1,"
  1.  S DIC(0)="XS"
  1.  S X=@DGROAR@(F,DFNC,FIELD)
  1.  D ^DIC
  1.  S DGROCTY(F,DFNC,FIELD)=+Y
  1.  D FILE^DIE("","DGROCTY","ERR") ;File County IEN
  1. NOCNTY K @DGROAR@(F,DFNC,FIELD)
  1.  K STATEIEN,DGROCTY
  1.  Q
  1.  ;
  1. FILEPEC ;File Internal value of Prim Elig Code
  1.  ;Called from CONVFDA^DGROHLR1
  1.  ;Remove this call when fields required by PEC are received
  1.  ; from LST
  1.  I $D(@DGROAR@(F,DFNC,FIELD)) DO
  1.  . S DIC="^DIC(8,"
  1.  . S DIC(0)="MNSX"
  1.  . S X=@DGROAR@(F,DFNC,FIELD)
  1.  . D ^DIC
  1.  . S DGROPEC(F,DFNC,FIELD)=+Y
  1.  . D FILE^DIE("","DGROPEC","ERR")
  1.  . K @DGROAR@(F,DFNC,FIELD)
  1.  . K DGROPEC,DIC,X
  1.  Q
  1.  ;
  1. FILE ;*Execute FILE or UPDATE per FNUM (1st subscpt) for file # according
  1.  ;* to file/multiple record add or adding existing Patient data add
  1.  S FNUM=$O(@DGROAR@(""))
  1.  K %DT ;* Clean up leaks from Input transforms that set %DT(0)
  1.  ;
  1.  ;* Patient file processing
  1.  I +FNUM=2 DO
  1.  . D FILE^DIE("E","@DGROAR","ERR") ;*Add to existing Patient entry
  1.  ;
  1.  ;* Patient file multiples processing
  1.  I (+FNUM=2.01)!(+FNUM=2.141)!(+FNUM=2.11) DO
  1.  . D UPDATE^DIE("E","@DGROAR","","ERR")
  1.  I +FNUM=2.3216 D
  1.  . D CONVERT ;Convert MSE fields to internal format
  1.  . D UPDATE^DIE("","@DGROAR","","ERR")
  1.  I (+FNUM=2.02)!(+FNUM=2.06) DO
  1.  . N DGRODNUM,DGIEN,DNUMDATA,DGIEN2,DGROIEN,DGFLD
  1.  . S DGRODNUM=0
  1.  . F  S DGRODNUM=$O(@DGROAR@(+FNUM,DGRODNUM)) Q:DGRODNUM=""  D
  1.  . . S DGIEN=$P(DGRODNUM,",")
  1.  . . I DGIEN S DGIEN2=$P(DGIEN,"+",2)
  1.  . . S DNUMDATA=$G(@DGROAR@(+FNUM,DGRODNUM,.01))
  1.  . . ; Changed FileMan call for processing of DINUM recs DG*5.3*897
  1.  . . ; I DGIEN2 S DGROIEN(DGIEN2)=DNUMDATA D
  1.  . . ; . D UPDATE^DIE("","@DGROAR","DGROIEN","ERR") ;*Converted Ext to Int
  1.  . . I DGIEN2 S DGROIEN(DGIEN2)=DNUMDATA
  1.  . . S DGFLD="."_$P(FNUM,".",2) D
  1.  . . . S (X,DINUM)=DNUMDATA,DIC="^DPT(DFN,DGFLD,",DA(1)=DFN,DIC(0)="L"
  1.  . . . K DO D FILE^DICN K DIC,X,DINUM,DA
  1.  ;
  1.  ;* Processing fields [indicated in 391.23] not part of Patient file.
  1.  ;* Define IF section for each file not a Patient file field or
  1.  ;* Multiple.
  1.  I (+$P(FNUM,".")'=2) DO
  1.  . I +FNUM=38.1 DO
  1.  . . N DGROARBI
  1.  . . S DGROARBI(1)=DFN ;*Set 38.1 IEN to DFN
  1.  . . D UPDATE^DIE("E","@DGROAR","DGROARBI","ERR")
  1.  ;
  1.  K @DGROAR
  1.  Q
  1.  ;
  1. SETARY ;* Setup arrays of data to be filed
  1.  N U,D,DATA,NODE,NODE2,INENNUM
  1.  ;
  1.  I '$D(^DGRO(391.23,"C",F,FIELD)) Q
  1.  ;
  1.  S U="^"
  1.  ;
  1.  ;CHECK LOCAL PATIENT FILE FOR EXISTING DATA, DO NOT OVERWRITE
  1.  S D=$$GET1^DIQ(F,DFNC,FIELD)
  1.  I D'="" K @DGDATA@(F,IEN,FIELD) Q
  1.  ;
  1.  S DATA=$G(@DGDATA@(F,IEN,FIELD,"E"))
  1.  Q:DATA=""
  1.  ;
  1.  ;* Design of this Subroutine:
  1.  ;* Set array defining groups of date for Fileman filing in
  1.  ;*  a predefined order.
  1.  ;* Indirection defined various array names for different ordered
  1.  ;*  data groups in CONVFDA.
  1.  ;* File Ext. values returned from LST per ORDER INDEX.
  1.  ;* DG*5.3*572
  1.  ;
  1.  ;* Get field entry IEN in ROM 391.23 file
  1.  S INENNUM=INX
  1.  ;
  1.  I F=2 DO  Q
  1.  . S @DGROAR@(F,DFNC,FIELD)=DATA ;*Indirection to Patient Array
  1.  . K @DGDATA@(F,IEN,FIELD)
  1.  ;
  1.  ;* Set array for all other files (not Patient or Security files)
  1.  ;* This section is for new entries in files.  Not for Multiples.
  1.  ;*  Code to process specific files needed in CONVFDA
  1.  I (+$P(F,".")'=2),(F'=38.1) DO  Q
  1.  . S @DGROAR@(F,"+1,",FIELD)=DATA
  1.  . K @DGDATA@(F,IEN,FIELD)
  1.  ;
  1.  ;SET ALIAS, CONFIDENTIAL ADDRESS CAT. AND MILITARY SERVICE EPISODE
  1.  ;SUBFILE ARRAYS
  1.  I (F=2.01)!(F=2.141)!(F=2.11)!(F=2.3216) D  Q
  1.  . S NODE2="+"
  1.  . S NODE2=NODE2_$P(IEN,",")_","_DFNC
  1.  . S @DGROAR@(F,NODE2,FIELD)=DATA ;*Indirection to Patient Array
  1.  . K @DGDATA@(F,IEN,FIELD)
  1.  ;
  1.  ;SET RACE AND ETHNICITY ARRAYS
  1.  I (F=2.02)!(F=2.06) D  Q
  1.  . N REFILE,REIEN,DATA30,QFL,DATACOMP,TEST,ERR,INACTIVE
  1.  . I (F=2.02),(FIELD=.01) S REFILE=10
  1.  . I (F=2.06),(FIELD=.01) S REFILE=10.2
  1.  . I FIELD=.02 S REFILE=10.3
  1.  . S DATA30=$E(DATA,1,30) D
  1.  . . S QFL=0,REIEN="",NODE=""
  1.  . . D FIND^DIC(REFILE,"","@;.01;200","",DATA30,,"B","","","TEST","ERR")
  1.  . . F  S NODE=$O(TEST("DILIST",2,NODE)) Q:'NODE  D  Q:$G(QFL)=1
  1.  . . . S REIEN=$G(TEST("DILIST",2,NODE))
  1.  . . . S INACTIVE=$G(TEST("DILIST","ID",NODE,200))
  1.  . . . Q:INACTIVE="YES"  ;* QUIT if Race or Eth Inact
  1.  . . . S DATACOMP=$G(TEST("DILIST","ID",NODE,.01))
  1.  . . . I DATACOMP=DATA S QFL=1
  1.  . Q:'QFL
  1.  . Q:$G(INACTIVE)="YES"  ;* No entry for Inactive Race/Ethncty
  1.  . S DATA=REIEN ;*Race/Ethncty/MOC (10/10.2/10.3) IEN for data recvd
  1.  . ;
  1.  . S NODE2="+" ;*+ for all fields, All fields added in one UPDATE
  1.  . S NODE2=NODE2_$P(IEN,",")_","_DFNC ;*No + for DFNC, DPT record exists
  1.  . S @DGROAR@(F,NODE2,FIELD)=DATA ;*Indirection to Patient Array
  1.  . K @DGDATA@(F,IEN,FIELD)
  1.  ;
  1.  ;* Set all sensitive fields (38.1) in array
  1.  I F=38.1 D  Q
  1.  . Q:('$D(@DGDATA@(F)))  ;*Data already filed
  1.  . S FIELD=.01
  1.  . S @DGROAR@(F,"+1,",FIELD)=$$GET1^DIQ(2,DFN,.01)
  1.  . F  S FIELD=$O(@DGDATA@(F,IEN,FIELD)) Q:'FIELD  D
  1.  . . S @DGROAR@(F,"+1,",FIELD)=@DGDATA@(F,IEN,FIELD,"E")
  1.  . K @DGDATA@(F,IEN)
  1.  . S FIELD=999999 ;*Skip to end of 38.1 field list in @DGDATA
  1.  Q
  1.  ;
  1. DIS(F,FIELD) ;Check for disabled
  1.  N SUB S SUB=$O(^DGRO(391.23,"C",F,FIELD,0)) Q:'SUB 1
  1.  I $P($G(^DGRO(391.23,SUB,0)),"^",5)=1 Q 1
  1.  Q 0
  1.  ;
  1. CONVERT ;External to Internal Conversion (clears field if no match found)
  1.  N BOS,DATE,COMP,DISCH,F,INTERNAL,LOCK,SUB,X,Y
  1.  S F=2.3216,SUB=""
  1.  F  S SUB=$O(@DGROAR@(F,SUB)) Q:SUB=""  D
  1.  .;Convert Branch
  1.  .I $D(@DGROAR@(F,SUB,.03)) D
  1.  ..S BOS=$G(@DGROAR@(F,SUB,.03)) Q:BOS=""
  1.  ..S INTERNAL=$O(^DIC(23,"B",BOS,""))
  1.  ..S @DGROAR@(F,SUB,.03)=INTERNAL
  1.  .;Convert Discharge
  1.  .I $D(@DGROAR@(F,SUB,.06)) D
  1.  ..S DISCH=$G(@DGROAR@(F,SUB,.06)) Q:DISCH=""
  1.  ..S INTERNAL=$O(^DIC(25,"B",DISCH,""))
  1.  ..S @DGROAR@(F,SUB,.06)=INTERNAL
  1.  .;Convert Component
  1.  .I $D(@DGROAR@(F,SUB,.04)) D
  1.  ..S COMP=$G(@DGROAR@(F,SUB,.04)) Q:COMP=""
  1.  ..S INTERNAL=""
  1.  ..S:COMP="REGULAR" INTERNAL="R"
  1.  ..S:COMP="ACTIVATED NG" INTERNAL="G"
  1.  ..S:COMP="ACTIVATED RESERVE" INTERNAL="V"
  1.  ..S @DGROAR@(F,SUB,.04)=INTERNAL
  1.  .;Convert Lock flag
  1.  .I $D(@DGROAR@(F,SUB,.07)) D
  1.  ..S LOCK=$G(@DGROAR@(F,SUB,.07)) Q:LOCK=""
  1.  ..S INTERNAL=$S(LOCK="YES":1,LOCK="NO":0,1:"")
  1.  ..S @DGROAR@(F,SUB,.07)=INTERNAL
  1.  .;Convert dates
  1.  .I $D(@DGROAR@(F,SUB,.01)) D
  1.  ..S X=$G(@DGROAR@(F,SUB,.01)) Q:X=""
  1.  ..D ^%DT
  1.  ..S @DGROAR@(F,SUB,.01)=Y
  1.  .I $D(@DGROAR@(F,SUB,.02)) D
  1.  ..S X=$G(@DGROAR@(F,SUB,.02)) Q:X=""
  1.  ..D ^%DT
  1.  ..S @DGROAR@(F,SUB,.02)=Y
  1.  Q