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