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

INMPORT.m

Go to the documentation of this file. 
  1. INMPORT ; cmi/flag/maw - IN Import GIS Package ; 
  1.  ;;3.01;BHL IHS Interfaces with GIS;**2,11,14,15**;OCT 15, 2002
  1.  ;
  1.  ;
  1.  ;
  1.  ;this routine will import a GIS package from the ^INXPORT global
  1.  ;it will then populate the SCRIPT GENERATOR FIELD, SEGMENT, and
  1.  ;MESSAGE files and also the INTERFACE TRANSACTION TYPE, DESTINATION,
  1.  ;and BACKGROUND PROCESS files
  1.  ;
  1. MAIN ;PEP - this is the main routine driver
  1.  I $O(^INXPORT(""))="" D  Q
  1.  . W !,"Global ^INXPORT is missing, please restore and rerun"
  1.  S KFM="K DIE,DR,DIC,DA,DD,DO,DIK"
  1.  D NS
  1.  D ADD01
  1.  D MSG
  1.  D EOJ
  1.  Q
  1.  ;
  1. NS ;-- parse the INXPORT global get package name        
  1.  S INMT=$O(^INXPORT(""))
  1.  Q:INMT=""
  1.  S INST=$O(^INXPORT(INMT,""))
  1.  Q:INST=""
  1.  S INPKG=$O(^INXPORT(INMT,INST,""))
  1.  I INPKG="" S INPKG="CORE"
  1.  I '$O(^INRHNS("B",INPKG,"")) D
  1.  . K DD,DO
  1.  . S DIC(0)="L",DIC="^INRHNS(",X=INPKG
  1.  . D FILE^DICN
  1.  . S INNS=+Y
  1.  . S DA(1)=INNS
  1.  . K DIC,DD,DO
  1.  . S DIC(0)="L"
  1.  . S DIC="^INRHNS("_DA(1)_",1,",X=INST,DIC("P")=$P(^DD(4007,1,0),U,2)
  1.  . D FILE^DICN
  1.  S INNS=$O(^INRHNS("B",INPKG,""))
  1.  S INSTOK=$$STCK(INNS,INST)
  1.  S INMPRE="^INXPORT(INMT,INST,INPKG)"
  1.  Q
  1.  ;
  1. MSG ;-- Import the fields from the INXPORT global
  1.  D ADDTT
  1.  D ADDD
  1.  D ADDBP
  1.  S INMDA=0
  1.  F  S INMDA=$O(@INMPRE@(INMDA)) Q:'INMDA  D
  1.  . D FD(INMDA)
  1.  . D SD(INMDA)
  1.  . S INOUT=$S($G(@INMPRE@(INMDA,"INOUT"))="IN":1,1:0)
  1.  . D MD(INMDA)
  1.  Q
  1.  ;
  1. FD(MDA)          ;-- parse the fields out of the message and check exist
  1.  ;add all fields first then go back and add sub fields if necessary
  1.  S INFDA=0 F  S INFDA=$O(@INMPRE@(MDA,"FD",INFDA)) Q:'INFDA  D
  1.  . S INFDEF=$G(@INMPRE@(MDA,"FD",INFDA))
  1.  . S INF01=$P(INFDEF,U)
  1.  . S INF02=$P(INFDEF,U,2)
  1.  . S INF03=$P(INFDEF,U,3)
  1.  . S INF3=$P(INFDEF,U,4)
  1.  . S INF5=$G(@INMPRE@(MDA,"FD",INFDA,"OUT"))
  1.  . S INY=+$$CHKF(INF01,INF02,INF03,INF3,INF5)
  1.  . Q:'INY
  1.  . I $D(@INMPRE@(MDA,"FD",INFDA,"SUB")) D
  1.  .. S INFS=0 F  S INFS=$O(@INMPRE@(MDA,"FD",INFDA,"SUB",INFS)) Q:'INFS  D
  1.  ... S INFSD=$G(@INMPRE@(MDA,"FD",INFDA,"SUB",INFS))
  1.  ... S INFS01=$P(INFSD,U)
  1.  ... S INFS02=$P(INFSD,U,2)
  1.  ... S INFSB=$$FSUB(INY,INFS01,INFS02)
  1.  K @INMPRE@(MDA,"FD")
  1.  Q
  1.  ;
  1. SD(MDA)          ;-- lets setup the segments
  1.  S INSDA=0 F  S INSDA=$O(@INMPRE@(MDA,"SD",INSDA)) Q:'INSDA  D
  1.  . S INSGDT=$G(@INMPRE@(MDA,"SD",INSDA))
  1.  . S INS01=$P(INSGDT,U)
  1.  . S INS02=$P(INSGDT,U,2)
  1.  . S INY=$$CHKS(INS01,INS02)
  1.  . Q:'INY
  1.  . S INSFDA=0 F  S INSFDA=$O(@INMPRE@(MDA,"SD",INSDA,"FD",INSFDA)) Q:'INSFDA  D
  1.  .. S INSFDT=$G(@INMPRE@(MDA,"SD",INSDA,"FD",INSFDA))
  1.  .. S INSF01=$P(INSFDT,U)
  1.  .. S INSFIEN=$O(^INTHL7F("B",INSF01,0))
  1.  .. Q:'INSFIEN
  1.  .. S INSF02=$P(INSFDT,U,2)
  1.  .. S INSF03=$P(INSFDT,U,3)
  1.  .. S INSFLD=$$SEGF(INY,INSFIEN,INSF01,INSF02,INSF03)
  1.  K @INMPRE@(MDA,"SD")
  1.  Q
  1.  ;
  1. MD(MDA) ;-- setup the message
  1.  S INMDT=$G(@INMPRE@(MDA,"MD"))
  1.  S INM01=$P($P(INMDT,";"),"///",2)
  1.  S INLKST=$G(@INMPRE@(MDA,"MD","ROU"))
  1.  S INY=$$CHKM(INM01,$P(INMDT,";",2,99)_INLKST)
  1.  D CHARUP^BHLU(INY)
  1.  S INMTT=0 F  S INMTT=$O(@INMPRE@(MDA,"MD","TT",INMTT)) Q:'INMTT  D
  1.  . S INMTTE=$G(@INMPRE@(MDA,"MD","TT",INMTT))
  1.  . S INTCHK=$$CHKMT(INY,INMTTE)
  1.  K @INMPRE@(MDA,"MD","TT")
  1.  S INMOM=0 F  S INMOM=$O(@INMPRE@(MDA,"MD","OIMC",INMOM)) Q:'INMOM  D
  1.  . S INOME=$G(@INMPRE@(MDA,"MD","OIMC",INMOM))
  1.  . S INOCHK=$$CHKOM(INY,INOME)
  1.  K @INMPRE@(MDA,"MD","OIMC")
  1.  S INMCL=0 F  S INMCL=$O(@INMPRE@(MDA,"MD","MCFL",INMCL)) Q:'INMCL  D
  1.  . S INMCLE=$G(@INMPRE@(MDA,"MD","MCFL",INMCL))
  1.  . S INMCCHK=$$CHKMC(INY,INMCLE)
  1.  K @INMPRE@(MDA,"MD","OIMC")
  1.  S INMDS=0 F  S INMDS=$O(@INMPRE@(MDA,"MD","DESC",INMDS)) Q:'INMDS  D
  1.  . S INDESC=$G(@INMPRE@(MDA,"MD","DESC",INMDS))
  1.  . S INMADS=$$CHKDS(INY,INDESC)
  1.  K @INMPRE@(MDA,"MD","DESC")
  1.  S INMSG=0 F  S INMSG=$O(@INMPRE@(MDA,"MD","SEG",INMSG)) Q:'INMSG  D
  1.  . S INMSGD=$G(@INMPRE@(MDA,"MD","SEG",INMSG))
  1.  . S INMSGN=$P(INMSGD,U)
  1.  . S INMSGS=$P(INMSGD,U,2)
  1.  . S INMSGR=$P(INMSGD,U,3)
  1.  . S INMSGOF=$P(INMSGD,U,4)
  1.  . S INMSGFL=$P(INMSGD,U,5)
  1.  . S INMSGP=$P(INMSGD,U,6)
  1.  . S INMSGM=$P(INMSGD,U,7)
  1.  . S INMSGPS=$P(INMSGD,U,8)
  1.  . S INMSGU=$P(INMSGD,U,9)
  1.  . S INMSY=$$CHKMS(INY,INMSGN,INMSGS,INMSGR,INMSGOF,INMSGFL,INMSGP,INMSGM,INMSGPS,INMSGU)
  1.  . K ^INTLH7M(INY,1,INMSY,5)  ;remove existing seg m code
  1.  . S INMSGO=0 F  S INMSGO=$O(@INMPRE@(MDA,"MD","SEG",INMSG,"OMC",INMSGO)) Q:'INMSGO  D
  1.  .. S INMSGOD=$G(@INMPRE@(MDA,"MD","SEG",INMSG,"OMC",INMSGO))
  1.  .. S INMSGOMC=$$CHKSOM(INY,INMSY,INMSGOD)
  1.  K @INMPRE@(MDA,"MD")
  1.  D COMPILE^BHLU(INY)
  1.  Q
  1.  ;
  1. STCK(NS,ST) ;-- check to see if the site already exists if not add it
  1.  S INNDA=0 F  S INNDA=$O(^INRHNS(NS,1,INNDA)) Q:'INNDA!($G(INIEN))  D
  1.  . I $G(^INRHNS(NS,1,INNDA,0))=ST S INIEN=INNDA Q
  1.  I '$G(INIEN) Q $$ADD(NS,ST)
  1.  Q INIEN
  1.  ;
  1. ADD(NMS,SIT)       ;-- add the site to the namespace file
  1.  X KFM
  1.  S DIC="^INRHNS("_NMS_",1,",DIC(0)="L"
  1.  S DIC("P")=$P(^DD(4007,1,0),U,2),X=SIT
  1.  D FILE^DICN
  1.  K DIC
  1.  Q +Y
  1.  ;
  1. CHKF(F01,F02,F03,F3,F5)          ;-- check for field add/update
  1.  X KFM
  1.  I $O(^INTHL7F("B",F01,0)) Q $$UPDF(F01,F02,F03,F3,F5)
  1.  S DIC="^INTHL7F(",DIC(0)="L",X=F01
  1.  S DIC("DR")=".02///"_F02_";.03///"_F03_";3///"_F3_";5///"_F5
  1.  D FILE^DICN
  1.  S FLDI=+Y
  1.  Q FLDI
  1.  ;
  1. CHKS(S01,S02)      ;-- check for seg existence add/update
  1.  X KFM
  1.  I $O(^INTHL7S("B",S01,0)) Q $O(^INTHL7S("B",S01,0))
  1.  S DIC="^INTHL7S(",DIC(0)="L",X=S01
  1.  S DIC("DR")=".02///"_S02
  1.  D FILE^DICN
  1.  Q +Y
  1.  ;
  1. CHKM(M01,MDT)      ;-- check for message process add/update
  1.  X KFM
  1.  I $O(^INTHL7M("B",M01,0)) D  Q MIEN
  1.  . S MIEN=$O(^INTHL7M("B",M01,0))
  1.  . S DIE="^INTHL7M(",DA=MIEN,DR=MDT
  1.  . D DIE
  1.  Q $$MADD(M01,MDT)
  1.  ;
  1. CHKMS(MS01,GN,GS,GR,GOF,GFL,GP,GM,GPS,GU)        ;-- check for msg segment mult
  1.  X KFM
  1.  S SGIEN=$O(^INTHL7S("B",GN,0))
  1.  S MSGIEN=$O(^INTHL7M("SEG",SGIEN,MS01,0))
  1.  I MSGIEN D
  1.  . S DIK="^INTHL7M("_MS01_",1,",DA(1)=MS01,DA=MSGIEN
  1.  . K ^INTHL7M(MS01,1,MSGIEN,1)
  1.  . D ^DIK
  1.  . Q
  1.  . S DIE="^INTHL7M("_MS01_",1,"_MSGIEN_",",DA(1)=MS01,DA=MSGIEN
  1.  . S DR=".02///"_GS_";.03///"_GR_";.04///"_GOF_";.05///"_GFL
  1.  . S DR=DR_";.07///"_GP_";.08///"_GM_";.11///"_GPS_";.12///"_GU
  1.  . S DIC("P")=$P(^DD(4011,1,0),U,2)
  1.  . D DIE
  1.  Q $$MSADD(MS01,SGIEN,GN,GS,GR,GOF,GFL,GP,GM,GPS,GU)
  1.  ;
  1. MSADD(MSGI,MSGN,AGN,AGS,AGR,AGOF,AGFL,AGP,AGM,AGPS,AGU)        ;-- add segment
  1.  X KFM
  1.  S DIC="^INTHL7M("_MSGI_",1,",DIC(0)="L",DA(1)=MSGI,X=MSGN
  1.  S DIC("DR")=".02///"_AGS_";.03///"_AGR_";.04///"_AGOF_";.05///"_AGFL
  1.  S DIC("DR")=DIC("DR")_";.07///"_AGP_";.08///"_AGM_";.11///"_AGPS
  1.  S DIC("DR")=DIC("DR")_";.12///"_AGU
  1.  S DIC("P")=$P(^DD(4011,1,0),U,2)
  1.  D FILE^DICN
  1.  Q +Y
  1.  ;
  1. UPDF(FL01,FL02,FL03,FL3,FL5)  ;-- update an existing field 
  1.  X KFM
  1.  S INFIEN=$O(^INTHL7F("B",FL01,0))
  1.  S DIE="^INTHL7F(",DA=INFIEN
  1.  S DR=".02///"_FL02_";.03///"_FL03_";3///"_FL3_";5///"_FL5
  1.  D DIE
  1.  Q INFIEN
  1.  ;
  1. FSUB(FDA,FS01,FS02)          ;-- check the subfields also
  1.  X KFM
  1.  S INFSIEN=$O(^INTHL7F("B",FS01,0))
  1.  I '$D(^INTHL7F(FDA,10)) Q $$FSUBADD(FDA,INFSIEN,FS02)
  1.  K INMTCH
  1.  S INFS=$O(^INTHL7F(FDA,10,"B",INFSIEN,0))
  1.  I $G(INFS) D  Q INFS
  1.  . Q:$P($G(^INTHL7F(FDA,10,INFS,0)),U,2)=FS02
  1.  . S DIE="^INTHL7F("_FDA_",10,"_INFS_","
  1.  . S DIC("P")=$P(^DD(4012,10,0),U,2)
  1.  . S DA(1)=FDA,DA=INFS,DR=".02///"_FS02
  1.  . D DIE
  1.  . K DIE
  1.  S INFSIEN=$O(^INTHL7F("B",FS01,0))
  1.  S FSIEN=$$FSUBADD(FDA,INFSIEN,FS02)
  1.  Q FSIEN
  1.  ;
  1. FSUBADD(FIEN,FSL01,FSL02)    ;-- add the subfile
  1.  X KFM
  1.  S DA(1)=FIEN,DIC="^INTHL7F("_DA(1)_",10,",X=FSL01
  1.  S DIC(0)="L",DIC("P")=$P(^DD(4012,10,0),U,2)
  1.  S DIC("DR")=".02///"_FSL02
  1.  D FILE^DICN
  1.  Q +Y
  1.  ;
  1. SEGF(SIEN,SFIEN,SF01,SF02,SF03)    ;-- check for fld exist add/upd
  1.  X KFM
  1.  I '$D(^INTHL7S(SIEN,1)) Q $$SFADD(SIEN,SFIEN,SF02,SF03)
  1.  S SFLIEN=$O(^INTHL7S(SIEN,1,"B",SFIEN,0))
  1.  I 'SFLIEN Q $$SFADD(SIEN,SFIEN,SF02,SF03)
  1.  S DIE="^INTHL7S("_SIEN_",1,"_SFLIEN_",",DA(1)=SIEN,DA=SFLIEN
  1.  I $P($G(^INTHL7S(SIEN,1,SFLIEN,0)),U,2)=SF02 Q SFLIEN
  1.  S DR=".02///"_SF02_";.03///"_SF03
  1.  D DIE
  1.  Q SFLIEN
  1.  ;
  1. SFADD(SN,S01,S02,S03)    ;-- add the field to the segment
  1.  X KFM
  1.  S DIC="^INTHL7S("_SN_",1,",DIC(0)="L",DA(1)=SN,X=S01
  1.  S DIC("P")=$P(^DD(4010,1,0),U,2)
  1.  S DIC("DR")=".02///"_S02_";.03///"_S03
  1.  D FILE^DICN
  1.  Q +Y
  1.  ;
  1. MADD(MA01,MADT)    ;-- add the message
  1.  X KFM
  1.  S DIC="^INTHL7M(",DIC(0)="L",X=MA01
  1.  S DIC("DR")=MADT
  1.  D FILE^DICN
  1.  Q +Y
  1.  ;
  1. CHKOM(MSG,OMC)     ;-- replace outgoing mumps code
  1.  K ^INTHL7M(INY,6)  ;kill off existing outgoing m code
  1.  X KFM
  1.  S DIC="^INTHL7M("_MSG_",6,",DIC(0)="L",DA(1)=MSG,X=OMC
  1.  S DIC("P")=$P(^DD(4011,6,0),U,2)
  1.  D FILE^DICN
  1.  Q +Y
  1.  ;
  1. CHKMC(MSG,MCL)     ;-- replace mumps code for lookup
  1.  K ^INTHL7M(INY,4)  ;kill off existing mumps code for lookup
  1.  X KFM
  1.  S DIC="^INTHL7M("_MSG_",4,",DIC(0)="L",DA(1)=MSG,X=MCL
  1.  S DIC("P")=$P(^DD(4011,4,0),U,2)
  1.  D FILE^DICN
  1.  Q +Y
  1.  ;
  1. CHKDS(MSG,DSC)     ;-- replace description
  1.  K ^INTHL7M(INY,3)  ;kill of existing description
  1.  X KFM
  1.  S DIC="^INTHL7M("_MSG_",3,",DIC(0)="L",DA(1)=MSG,X=DSC
  1.  S DIC("P")=$P(^DD(4011,3,0),U,2)
  1.  D FILE^DICN
  1.  Q +Y
  1.  ;
  1. CHKMT(MSG,MTT)     ;-- add tt to msg
  1.  X KFM
  1.  S MTIEN=$O(^INRHT("B",MTT,0))
  1.  I 'MTIEN Q 0
  1.  I '$O(^INTHL7M(MSG,2,"B",MTIEN,0)) Q $$ADDT(MSG,MTIEN)
  1.  Q $O(^INTHL7M(MSG,2,"B",MTIEN,0))
  1.  ;
  1. ADDT(MSG,TT)       ;-- add the transaction to the message
  1.  X KFM
  1.  S DIC="^INTHL7M("_MSG_",2,",DA(1)=MSG,DIC(0)="L",X=TT
  1.  S DIC("P")=$P(^DD(4011,2,0),U,2)
  1.  D FILE^DICN
  1.  Q +Y
  1.  ;
  1. CHKSOM(MS,MSEG,OMC)          ;-- add m code to segment
  1.  K ^INTHL7M(MS,1,MSEG,1)  ;remove existing seg m code
  1.  X KFM
  1.  S DIC="^INTHL7M("_MS_",1,"_MSEG_",5,",DIC(0)="L",DA(1)=MS,DA=MSEG
  1.  S DIC("P")=$P(^DD(4011.01,5,0),U,2)
  1.  S X=OMC
  1.  D FILE^DICN
  1.  Q +Y
  1.  ;
  1. ADD01 ;
  1.  S INADD01=""
  1.  D ADDTT
  1.  D ADDD
  1.  D ADDBP
  1.  K INADD01
  1.  Q
  1. ADDD ;-- add all destinations in namespace first    
  1.  S INADA=0
  1.  F  S INADA=$O(@INMPRE@("DEST",INADA)) Q:'INADA  D
  1.  .S INADDT=$G(@INMPRE@("DEST",INADA))
  1.  .S INAD01=$P($P(INADDT,";"),"///",2)
  1.  .S INAD02=$P($P(INADDT,";",2),"///",2)
  1.  .S:INAD02]"" INAD02=$O(^INRHT("B",INAD02,0))
  1.  .S INADDR=$P(INADDT,";",2,99)
  1.  .I INAD02 S $P(INADDR,";")=".02////"_INAD02
  1.  .X KFM
  1.  .S INDIEN=$O(^INRHD("B",INAD01,0))
  1.  .I 'INDIEN D  Q:INDIEN<0
  1.  ..S DIC="^INRHD(",DIC(0)="L",X=INAD01
  1.  ..D FILE^DICN
  1.  ..S INDIEN=+Y
  1.  .Q:$D(INADD01)
  1.  .S DA=INDIEN
  1.  .S DIE="^INRHD("
  1.  .S DR=INADDR
  1.  .D DIE
  1.  .I INAD02,'$P(^INRHD(INDIEN,0),U,2) S $P(^(0),U,2)=INAD02
  1.  Q
  1.  ;
  1. ADDTT ;-- add all transactions in namespace first    
  1.  S INADA=0
  1.  F  S INADA=$O(@INMPRE@("TT",INADA)) Q:'INADA  D
  1.  .S INADDT=$G(@INMPRE@("TT",INADA))
  1.  .S INAD01=$P($P(INADDT,";"),"///",2)
  1.  .S INADDR=$P(INADDT,";",2,99)
  1.  .X KFM
  1.  .S INDIEN=$O(^INRHT("B",INAD01,0))
  1.  .I 'INDIEN D  Q:INDIEN<0
  1.  ..S DIC="^INRHT(",DIC(0)="L",X=INAD01
  1.  ..D FILE^DICN
  1.  ..S INDIEN=+Y
  1.  .Q:$D(INADD01)
  1.  .S DA=INDIEN
  1.  .N INTP5
  1.  .S INTP5=$P($G(^INRHT(INDIEN,0)),U,5)
  1.  .S DIE="^INRHT("
  1.  .S DR=INADDR
  1.  .D DIE
  1.  .I $G(INTP5)="A" D
  1.  .. S $P(^INRHT(INDIEN,0),U,5)="A"
  1.  Q
  1.  ;
  1. ADDBP ;-- add all transactions in namespace first    
  1.  S INADA=0
  1.  F  S INADA=$O(@INMPRE@("BP",INADA)) Q:'INADA  D
  1.  .S INADDT=$G(@INMPRE@("BP",INADA))
  1.  .S INAD01=$P($P(INADDT,";"),"///",2)
  1.  .S INADDR=$P(INADDT,";",2,99)
  1.  .X KFM
  1.  .S INDIEN=$O(^INTHPC("B",INAD01,0))
  1.  .I 'INDIEN D  Q:INDIEN<0
  1.  ..S DIC="^INTHPC(",DIC(0)="L",X=INAD01
  1.  ..D FILE^DICN
  1.  ..S INDIEN=+Y
  1.  .Q:$D(INADD01)
  1.  .S DIE="^INTHPC(",DA=INDIEN
  1.  .S DR=INADDR
  1.  .D DIE
  1.  Q
  1.  ;
  1. EOJ ;-- kill variables and quit
  1.  D EN^XBVK("IN")
  1.  Q
  1.  ;
  1. DIE K Y
  1.  D ^DIE
  1.  K DA,DR,DIE,DIC,DINUM,Y
  1.  Q