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

MCUIMAG0.m

Go to the documentation of this file.
  1. MCUIMAG0 ;HCIOFO/DAD-Create / Update Med Procedure with Image Pointer ;7/23/97 07:36
  1. ;;2.3;Medicine;**7,12**;09/13/1996
  1. Q
  1. ;
  1. UPDATE(MCDATE,MCPROCD0,MCDFN,MCMAGPTR,MCD0,OK) ;
  1. ; *** Main driver to update Medicine files from Imaging ***
  1. ; MCDATE = Date/Time of procedure (FM internal format)
  1. ; MCPROCD0 = Pointer to the Procedure/Subspecialty file (#697.2)
  1. ; MCDFN = Pointer to the Patient file (#2)
  1. ; MCMAGPTR() = An array whose subscripts are pointers to the Image
  1. ; file (#2005) Returned as: MCMAGPTR(File 2005 IEN)=
  1. ; MCFILE ^ MCD0 ^ MCD1 (IEN of image in image mult)
  1. ; MCD0 = Pointer to one of the Medicine Procedure data files
  1. ; OK = A return flag: '1^Message' = All is well, '0^Message' = Bad news
  1. N DD,DIC,DINUM,DO,MCPATFLD,X,Y
  1. S MCDATE=+$G(MCDATE),MCPROCD0=+$G(MCPROCD0)
  1. S MCDFN=+$G(MCDFN),MCD0=+$G(MCD0)
  1. S MCFILE=+$P($P($G(^MCAR(697.2,MCPROCD0,0)),U,2),"(",2)
  1. I MCFILE'>0 D Q
  1. . S OK="0^Medicine Procedure file global location not found"
  1. . Q
  1. S MCPATFLD=$$PATFLD(MCFILE)
  1. I MCPATFLD'>0 D Q
  1. . S OK="0^Medical Patient field not found in Medicine Procedure file"
  1. . Q
  1. I MCD0>0 S OK=$$VALID(MCFILE,MCD0,MCDFN,MCPROCD0) Q:'OK
  1. I MCD0'>0 D Q:'OK
  1. . N MCIEN S MCIEN=0
  1. . F S MCIEN=$O(^MCAR(MCFILE,"B",MCDATE,MCIEN)) Q:MCIEN'>0 D Q:MCD0
  1. .. S OK=$$VALID(MCFILE,MCIEN,MCDFN,MCPROCD0)
  1. .. I OK S MCD0=MCIEN
  1. .. Q
  1. . I MCD0'>0 D NEW(MCDATE,MCDFN,MCFILE,MCPROCD0,MCPATFLD,.MCD0,.OK)
  1. . Q
  1. I $O(MCMAGPTR(0)) D FILE(MCD0,MCFILE,.MCMAGPTR,.OK) Q:'OK
  1. S MCD0=MCD0_U_MCFILE
  1. Q
  1. ;
  1. NEW(MCDATE,MCDFN,MCFILE,MCPROCD0,MCPATFLD,MCD0,OK) ;
  1. ; *** Create new Medicine patient (if needed) and procedure records ***
  1. ; MCDATE = Date/Time of procedure (FM internal format)
  1. ; MCDFN = Pointer to the Patient file (#2)
  1. ; MCFILE = File number of one of the Medicine Procedure data files
  1. ; MCPROCD0 = Pointer to the Procedure/Subspecialty file (#697.2)
  1. ; MCPATFLD = Field# in one of the Medicine Procedure data files
  1. ; that points to the Medical Patient file (#690)
  1. ; MCD0 = Pointer to one of the Medicine Procedure data files
  1. ; OK = A return flag: '1^Message' = All is well, '0^Message' = Bad news
  1. N DD,DIC,DINUM,DLAYGO,DO,MCARCODE,MCPRCFLD,MCRESULT,X,Y
  1. S OK="1^New stub record created in Medicine Procedure data file"
  1. ; *** Create a new record in the Medical Patient file (#690) ***
  1. I '$D(^MCAR(690,MCDFN)) D Q:'OK
  1. . K DD,DIC,DINUM,DO
  1. . S (X,DINUM)=MCDFN,DLAYGO=690
  1. . S DIC="^MCAR(690,",DIC(0)="L"
  1. . D FILE^DICN
  1. . I Y'>0 D
  1. .. S OK="0^Cannot add patient to Medical Patient file"
  1. .. Q
  1. . Q
  1. ; *** Create a stub record ***
  1. K DD,DIC,DINUM,DO
  1. S DIC=$$GET1^DID(MCFILE,"","","GLOBAL NAME")
  1. S DIC(0)="L",DLAYGO=MCFILE
  1. S DIC("DR")=MCPATFLD_"///`"_MCDFN
  1. S MCARCODE=$P($G(^MCAR(697.2,MCPROCD0,0)),U,4) S:MCARCODE="" MCARCODE=U
  1. S MCPRCFLD=$$PRCFLD(MCFILE)
  1. I MCPRCFLD>0 D PRCSUBS Q:'OK
  1. S X=MCDATE
  1. D FILE^DICN S MCD0=+Y
  1. I MCD0'>0 D
  1. . S OK="0^Cannot create stub record in the Medicine Procedure data file"
  1. . Q
  1. Q
  1. ;
  1. FILE(MCD0,MCFILE,MCMAGPTR,OK) ;
  1. ; *** Store the Image file (#2005) pointers in Med Proc data files ***
  1. ; MCD0 = Pointer to one of the Medicine Procedure data files
  1. ; MCFILE = File number of one of the Medicine Procedure data files
  1. ; MCMAGPTR() = An array whose subscripts are pointers to the Image
  1. ; file (#2005) Returned as: MCMAGPTR(File 2005 IEN)=
  1. ; MCFILE ^ MCD0 ^ MCD1 (IEN of image in image mult)
  1. ; OK = A return flag: '1^Message' = All is well, '0^Message' = Bad news
  1. N DD,DIC,DINUM,DLAYGO,DO,MCD1,MCDIC,MCMAGD0,MCNODE,X,Y
  1. S OK="1^The Medicine Procedure file has been updated"
  1. I $O(MCMAGPTR(0))'>0 D Q
  1. . S OK="0^No image number to file in Medicine Procedure file"
  1. . Q
  1. I $$VFIELD^DILFD(MCFILE,2005)'>0 D Q
  1. . S OK="0^Image field not found in the Medicine Procedure file"
  1. . Q
  1. S MCNODE=$P($$GET1^DID(MCFILE,2005,"","GLOBAL SUBSCRIPT LOCATION"),";")
  1. I MCNODE="" D Q
  1. . S OK="0^Medicine Procedure file global subscript location not found"
  1. . Q
  1. S MCDIC=$$GET1^DID(MCFILE,"","","GLOBAL NAME")_MCD0_","
  1. S MCDIC=MCDIC_$S(MCNODE=+MCNODE:MCNODE,1:""""_MCNODE_"""")_","
  1. S MCDIC("P")=$$GET1^DID(MCFILE,2005,"","SPECIFIER")
  1. S MCMAGD0=0
  1. F S MCMAGD0=$O(MCMAGPTR(MCMAGD0)) Q:MCMAGD0'>0 D Q:'OK
  1. . S MCD1=+$O(^MCAR(MCFILE,MCD0,MCNODE,"B",MCMAGD0,0))
  1. . I MCMAGD0'=$P($G(^MCAR(MCFILE,MCD0,MCNODE,MCD1,0)),U) S MCD1=0
  1. . K DD,DIC,DINUM,DO
  1. . S DIC=MCDIC,DIC(0)="L",DIC("P")=MCDIC("P")
  1. . S DLAYGO=MCFILE,(D0,DA(1))=MCD0
  1. . S X=MCMAGD0
  1. . I MCD1'>0 D
  1. .. D FILE^DICN S MCD1=+Y
  1. .. I MCD1'>0 S OK="0^Cannot add image to Medicine Procedure file"
  1. .. Q
  1. . I OK S MCMAGPTR(MCMAGD0)=MCFILE_U_MCD0_U_MCD1
  1. . Q
  1. Q
  1. ;
  1. VALID(FILE,IEN,DFN,PRC) ;
  1. ; *** Make sure we have the right Medicine Procedure data file rec ***
  1. ; FILE = File number of one of the Medicine Procedure data files
  1. ; IEN = Pointer to one of the Medicine Procedure data files
  1. ; DFN = Pointer to the Patient file (#2)
  1. ; PRC = Pointer to the Procedure/Subspecialty file (#697.2)
  1. ; Returns
  1. ; '1^Message' = All is well, '0^Message' = Bad news
  1. N FIELD,OK,TYPE
  1. S OK="1^Record match found"
  1. S FIELD=$$PATFLD(FILE)
  1. I FIELD,$$GET1^DIQ(FILE,IEN,FIELD,"I")'=DFN D
  1. . S OK="0^Patient mismatch"
  1. . Q
  1. S FIELD=$$PRCFLD(FILE),TYPE=$$PRCTYPE(PRC)
  1. ; *** Old Generalized Procedures module and other modules
  1. I (MCFILE'=699.5)!((MCFILE=699.5)&($$VFILE^DILFD(MCFILE,.06)'>0)) D
  1. . S FIELD=$P(FIELD,U)
  1. . Q
  1. ; *** New Generalized Procedures module
  1. I (MCFILE=699.5)&($$VFIELD^DILFD(MCFILE,.06)>0) D
  1. . S FIELD=$S(TYPE="S":$P(FIELD,U),TYPE="P":$P(FIELD,U,2),1:0)
  1. . Q
  1. I FIELD,$$GET1^DIQ(FILE,IEN,FIELD,"I")'=PRC D
  1. . S OK="0^Procedure/Subspecialty mismatch"
  1. . Q
  1. Q OK
  1. ;
  1. PRCFLD(FILE) ;
  1. ; *** Procedure/Subspecialty pointer field ***
  1. ; FILE = File number of one of the Medicine Procedure data files
  1. ; Returns
  1. ; The field# in one of the Medicine Procedure data files that points
  1. ; to the Procedure/Subspecialty file (#690) (Zero [0] if not found)
  1. N PRCFLD
  1. S PRCFLD(694)=2,PRCFLD(694.8)=9,PRCFLD(699)=1,PRCFLD(699.5)=".05^.06"
  1. Q $G(PRCFLD(FILE),0)
  1. ;
  1. PATFLD(FILE) ;
  1. ; *** Medical Patient pointer field ***
  1. ; FILE = File number of one of the Medicine Procedure data files
  1. ; Returns
  1. ; The field# in one of the Medicine Procedure data files that points
  1. ; to the Medical Patient file (#690) (Zero [0] if not found)
  1. N MEDPAT
  1. S MEDPAT(691)=1,MEDPAT(691.1)=1,MEDPAT(691.5)=1,MEDPAT(691.6)=1
  1. S MEDPAT(691.7)=1,MEDPAT(691.8)=1,MEDPAT(694)=1,MEDPAT(694.5)=1
  1. S MEDPAT(698)=1,MEDPAT(698.1)=1,MEDPAT(698.2)=1,MEDPAT(698.3)=1
  1. S MEDPAT(699)=.02,MEDPAT(699.5)=.02,MEDPAT(700)=1,MEDPAT(701)=1
  1. Q $G(MEDPAT(FILE),0)
  1. ;
  1. PRCSUBS ; *** Procedure/Subspecialty DIC("DR") builder ***
  1. ; *** Old Generalized Procedures module and other modules
  1. N MCGENPRC,MCGENSUB,MCPRCTYP
  1. I (MCFILE'=699.5)!((MCFILE=699.5)&($$VFIELD^DILFD(MCFILE,.06)'>0)) D
  1. . D PRCTEST(MCFILE,$P(MCPRCFLD,U),MCPROCD0,.OK)
  1. . S DIC("DR")=DIC("DR")_";"_$P(MCPRCFLD,U)_"///`"_MCPROCD0
  1. . Q
  1. ; *** New Generalized Procedures module
  1. I (MCFILE=699.5)&($$VFIELD^DILFD(MCFILE,.06)>0) D
  1. . S MCGENPRC=$$FINDPRC("GENERIC PROCEDURE","P")
  1. . I MCGENPRC'>0 S OK="0^Entry 'GENERIC PROCEDURE' not found" Q
  1. . S MCGENSUB=$$FINDPRC("GENERIC SUBSPECIALTY","S")
  1. . I MCGENSUB'>0 S OK="0^Entry 'GENERIC SUBSPECIALTY' not found" Q
  1. . S MCPRCTYP=$$PRCTYPE(MCPROCD0)
  1. . I "^P^S^"'[(U_MCPRCTYP_U) S OK="0^Invalid Procedure/Subspecialty" Q
  1. . D PRCTEST(MCFILE,$P(MCPRCFLD,U,$TR(MCPRCTYP,"PS","21")),MCPROCD0,.OK)
  1. . I MCPRCTYP="P" D
  1. .. S DIC("DR")=DIC("DR")_";"_$P(MCPRCFLD,U)_"///`"_MCGENSUB
  1. .. S DIC("DR")=DIC("DR")_";"_$P(MCPRCFLD,U,2)_"///`"_MCPROCD0
  1. .. Q
  1. . I MCPRCTYP="S" D
  1. .. S DIC("DR")=DIC("DR")_";"_$P(MCPRCFLD,U)_"///`"_MCPROCD0
  1. .. S DIC("DR")=DIC("DR")_";"_$P(MCPRCFLD,U,2)_"///`"_MCGENPRC
  1. .. Q
  1. . Q
  1. Q
  1. ;
  1. PRCTEST(MCFILE,MCPRCFLD,MCPROCD0,OK) ;
  1. ; *** Test for valid procedure
  1. N MCRESULT
  1. D CHK^DIE(MCFILE,MCPRCFLD,"","`"_MCPROCD0,.MCRESULT)
  1. K ^TMP("DIERR",$J)
  1. I MCRESULT=U S OK="0^Procedure is invalid"
  1. Q
  1. ;
  1. PRCTYPE(MCPROCD0) ;
  1. ; *** Return the procedure type ***
  1. Q $P($G(^MCAR(697.2,MCPROCD0,1)),U)
  1. ;
  1. FINDPRC(MCENTRY,MCTYPE) ;
  1. ; *** Find a procedure ***
  1. ; MCENTRY = External name of the entry (697.2,.01)
  1. ; MCTYPE = Internal 'Procedure/Subspecialty' type (697.2,1001)
  1. ; Returns
  1. ; The IEN of the procedure or zero if not found.
  1. N MCFOUND,MCIEN
  1. S (MCIEN,MCFOUND)=0
  1. F S MCIEN=$O(^MCAR(697.2,"B",MCENTRY,MCIEN)) Q:MCIEN'>0 D Q:MCFOUND
  1. . I $P($G(^MCAR(697.2,MCIEN,0)),U)=MCENTRY D
  1. .. I $P($G(^MCAR(697.2,MCIEN,1)),U)=MCTYPE S MCFOUND=1
  1. .. Q
  1. . Q
  1. Q +MCIEN
  1. ;
  1. KILL(MCFILE,MCD0,MCD1,OK) ;
  1. ; *** Remove an image from Image multiple ***
  1. ; MCFILE = A Medicine Procedure data file number
  1. ; MCD0 = Pointer to one of the Medicine Procedure data files
  1. ; MCD1 = Pointer to one of the entries in the in the Image multiple
  1. ; OK = A return flag: '1^Message' = All is well, '0^Message' = Bad news
  1. N D0,D1,DA,DIK,MCNODE
  1. S OK="1^Image pointer deleted from Medicine Procedure file"
  1. I $$VFIELD^DILFD(MCFILE,2005)'>0 D Q
  1. . S OK="0^Image field not found in the Medicine Procedure file"
  1. . Q
  1. S DIK=$$GET1^DID(MCFILE,"","","GLOBAL NAME")
  1. I DIK="" D Q
  1. . S OK="0^Medicine Procedure file global name not found"
  1. . Q
  1. S MCNODE=$P($$GET1^DID(MCFILE,2005,"","GLOBAL SUBSCRIPT LOCATION"),";")
  1. I MCNODE="" D Q
  1. . S OK="0^Medicine Procedure file global subscript location not found"
  1. . Q
  1. S DIK=DIK_MCD0_","_$S(MCNODE=+MCNODE:MCNODE,1:""""_MCNODE_"""")_","
  1. S (D0,DA(1))=MCD0,(D1,DA)=MCD1
  1. D ^DIK
  1. Q