- 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 Feb 18, 2025@23:43:23 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