PXMCLINK ;SLC/PKR - Mapped codes linking and unlinking routines. ;02/20/2019
;;1.0;PCE PATIENT CARE ENCOUNTER;**211**;Aug 12, 1996;Build 454
;
;==========================================
ASSOVFILE(FILENUM) ;Given a PCE data type file number return the associated
;V file number.
Q $S(FILENUM=9999999.09:9000010.16,FILENUM=9999999.15:9000010.13,FILENUM=9999999.64:9000010.23,1:"")
;
;==========================================
CSCLIST(GBL,IEN,CODESYSL) ;Populate the coding system code list.
N CODE,COESYS,IND,TEMP
K CODESYSL
S IND=0
F S IND=+$O(@GBL@(IEN,210,IND)) Q:IND=0 D
. S TEMP=@GBL@(IEN,210,IND,0)
.;Skip if there already is a Date Linked.
. I $P(TEMP,U,4)'="" Q
. S CODESYS=$P(TEMP,U,1),CODE=$P(TEMP,U,2)
. I CODE'="" S CODESYSL(CODESYS,CODE)=IND
Q
;
;==========================================
DELCHK(CODESYSL) ;When there are mappings that are being deleted,
;if they are also on the list to link remove them from the list to
;link.
N CODE,CODESYS,DA,GBL,IENS,TEMP,UNLINK
M UNLINK=^TMP($J,"UNLINK")
S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
S GBL=$P(GBL,"(",1)
S IENS=""
F S IENS=$O(UNLINK(FILENUM,IENS)) Q:IENS="" D
. D DA^DILF(IENS,.DA)
. S TEMP=@GBL@(DA(1),210,DA,0)
. S CODESYS=$P(TEMP,U,1)
. S CODE=$P(TEMP,U,2)
. K CODESYSL(CODESYS,CODE)
Q
;
;==========================================
DELMC(FILENUM,CODESYS,CODE,IENS) ;Delete a mapped code.
;Before deletion save the mapped code in the Deleted Code Mappings
;multiple.
N ADDIENS,CMSFN,DCMSFN,FDA,KFDA,IEN,MSG,SUBJECT
S IEN=$P(IENS,",",2)
S ADDIENS="+1,"_IEN_","
S DCMSFN=+$$GET1^DID(FILENUM,"DELETED CODE MAPPINGS","","SPECIFIER")
S FDA(DCMSFN,ADDIENS,.01)=CODESYS
S FDA(DCMSFN,ADDIENS,1)=CODE
S FDA(DCMSFN,ADDIENS,2)=$$NOW^XLFDT
S FDA(DCMSFN,ADDIENS,3)=DUZ
D UPDATE^DIE("","FDA","","MSG")
I $D(DIERR) D Q
. N TEXT
. S TEXT(1)="IENS="_IENS
. S TEXT(2)="CODESYS="_CODESYS_", CODE="_CODE
. S SUBJECT="Mapped code copy before deletion failed for file #"_FILENUM
. D SENDEMSG(SUBJECT,.MSG,.TEXT)
S CMSFN=+$$GET1^DID(FILENUM,"CODE MAPPINGS","","SPECIFIER")
S KFDA(CMSFN,IENS,.01)="@"
D FILE^DIE("","KFDA","MSG")
I $D(DIERR) D Q
. N TEXT
. S TEXT(1)="IENS="_IENS
. S TEXT(2)="CODESYS="_CODESYS_", CODE="_CODE
. S SUBJECT="Mapped code deletion failed for file #"_FILENUM
. D SENDEMSG(SUBJECT,.MSG,.TEXT)
Q
;
;==========================================
LINK(FILENUM,GBL,IEN,CODESYSL) ;Create entries in V Standard Codes file for
;legacy data that has been mapped to standard codes and link them
;through the Mapped Source field.
;FILENUM is the file number of the data type file.
;GBL is the corresponding global
;IEN is the internal entry number of the data type.
;CODESYSL is the list of mapped codes: (CODESYS,CODE)
N ASSOVFILE,CODE,CODEDT,CODEIEN,CODESYS,DAS,DATE,DFN,ERROR,FDA,FDAIEN
N FROM,IENS,IND,MSG,MSOURCE,NUMLINK,NL,SUBJECT,TO
N VCODFNUM,VFDATA,VISITIEN
K ^TMP("PXXMZ",$J)
S ASSOVFILE=$$ASSOVFILE(FILENUM)
I '$D(^PXRMINDX(ASSOVFILE,"IP",IEN)) Q
S MSOURCE=FILENUM_";"_IEN
S IENS="+1,"
S CODESYS="",NL=2
S VCODFNUM=9000010.71
F S CODESYS=$O(CODESYSL(CODESYS)) Q:CODESYS="" D
. K FDA
. S FDA(VCODFNUM,IENS,300)=MSOURCE
. S FDA(VCODFNUM,IENS,.05)=CODESYS
. S CODE=""
. F S CODE=$O(CODESYSL(CODESYS,CODE)) Q:CODE="" D
.. S NUMLINK(CODESYS,CODE)=0
.. S FDA(VCODFNUM,IENS,.01)=CODE
.. S DFN=""
.. F S DFN=$O(^PXRMINDX(ASSOVFILE,"IP",IEN,DFN)) Q:DFN="" D
... S ERROR=0
... S FDA(VCODFNUM,IENS,.02)=DFN
... S DATE=""
... F S DATE=$O(^PXRMINDX(ASSOVFILE,"IP",IEN,DFN,DATE)) Q:DATE="" D
.... S DAS=""
.... F S DAS=$O(^PXRMINDX(ASSOVFILE,"IP",IEN,DFN,DATE,DAS)) Q:DAS="" D
..... D VFDATA(VCODFNUM,ASSOVFILE,DAS,IENS,.FDA)
.....;If the code is a duplicate do not add it.
..... S VISITIEN=FDA(VCODFNUM,IENS,.03)
..... S CODEDT=FDA(VCODFNUM,IENS,1201)
..... I CODEDT="" S CODEDT=$P(^AUPNVSIT(VISITIEN,0),U,1)
..... I $$VSCDUP^PXKMCODE(CODESYS,CODE,VISITIEN,CODEDT,MSOURCE) Q
..... K FDAIEN,MSG
..... D UPDATE^DIE("S","FDA","FDAIEN","MSG")
..... I $D(DIERR) D Q
...... S ERROR=1
...... S SUBJECT="Mapped code linking failed for file #"_FILENUM_", IEN="_IEN_", DFN="_DFN
...... D SENDEMSG(SUBJECT,.MSG)
..... S NUMLINK(CODESYS,CODE)=NUMLINK(CODESYS,CODE)+1
.....;Fire PXK VISIT DATA EVENT for the addition of a code.
..... D ADDEVENT^PXMCEVNT(VCODFNUM,FDAIEN(1))
I ERROR K ^TMP("PXXMZ",$J) Q
N ENAME,GNAME,LINKDT
D SETTF(.TO,.FROM)
S GNAME=$$GET1^DID(FILENUM,"","","NAME")
S ENAME=$P($G(@GBL@(IEN,0)),U,1)
S SUBJECT=GNAME_" entry "_ENAME_" has been linked."
S LINKDT=$$NOW^XLFDT
S ^TMP("PXXMZ",$J,1,0)="Linking completed at "_$$FMTE^XLFDT(LINKDT,"5Z")
S ^TMP("PXXMZ",$J,2,0)="The following codes were linked:"
S CODESYS=""
F S CODESYS=$O(CODESYSL(CODESYS)) Q:CODESYS="" D
. S CODE=""
. F S CODE=$O(CODESYSL(CODESYS,CODE)) Q:CODE="" D
..;Set the Date Linked.
.. S IND=CODESYSL(CODESYS,CODE)
.. S $P(@GBL@(IEN,210,IND,0),U,4)=LINKDT
.. S NL=NL+1,^TMP("PXXMZ",$J,NL,0)=" "_CODESYS_": "_CODE
.. I NUMLINK(CODESYS,CODE)>0 D
... S NL=NL+1,^TMP("PXXMZ",$J,NL,0)=" There were "_NUMLINK(CODESYS,CODE)_" instances where the code was linked."
.. S NL=NL+1,^TMP("PXXMZ",$J,NL,0)=""
D SEND^PXMSG("PXXMZ",SUBJECT,.TO,FROM)
K ^TMP("PXXMZ",$J)
Q
;
;==========================================
LINKALL ;Link all national exams, education topics, and health factors
;that have been mapped.
N CLASS,IEN,FILENUM,GBL,GNAME,NL,NMAPPED,TEXT
K ^TMP("PXXMZ",$J)
S NL=1
F FILENUM=9999999.09,9999999.15,9999999.64 D
. S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
. S GBL=$P(GBL,"(",1)
. S GNAME=$$GET1^DID(FILENUM,"","","NAME")
. S NL=NL+1,^TMP("PXXMZ",$J,NL,0)=""
. S NL=NL+1,^TMP("PXXMZ",$J,NL,0)="Linking national "_GNAME_" that have been mapped."
. S IEN=0
. F S IEN=+$O(@GBL@(IEN)) Q:IEN=0 D
.. S NMAPPED=+$P($G(@GBL@(IEN,210,0)),U,4)
.. I NMAPPED=0 Q
.. S CLASS=$P(@GBL@(IEN,100),U,1)
.. I CLASS'="N" Q
.. S NL=NL+1,^TMP("PXXMZ",$J,NL,0)=" Linking "_GNAME_": "_$P(@GBL@(IEN,0),U,1)
.. D CSCLIST^PXMCLINK(GBL,IEN,.CODESYSL)
.. I '$D(CODESYSL) Q
.. D LINK^PXMCLINK(FILENUM,GBL,IEN,CODESYSL,0)
D SEND^PXMSG("PXXMZ","LINKING NATIONAL PCE ENTRIES",DUZ,"PCE")
K ^TMP("PXXMZ",$J)
Q
;
;==========================================
MCLINK(FILENUM,IEN) ;Check for codes that have been mapped but not linked,
;called from ScreenMan form post-save.
;It there are any, ask the user if they want to link them.
N CODE,CODESYS,CODESYSL,DDS,DIR,DIR0,ENAME,GBL,GNAME,NL,NMAPPED
N STARTDT,TEMP,TEXT,VFILENUM,X,Y
S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
S GBL=$P(GBL,"(",1)
S NMAPPED=+$P($G(@GBL@(IEN,210,0)),U,4)
I NMAPPED=0 Q
S GNAME=$$GET1^DID(FILENUM,"","","NAME")
S ENAME=$P($G(@GBL@(IEN,0)),U,1)
D CSCLIST^PXMCLINK(GBL,IEN,.CODESYSL)
I $D(^TMP($J,"UNLINK",FILENUM)) D DELCHK(.CODESYSL)
I '$D(CODESYSL) Q
S TEXT(1)="The following codes have been mapped but not linked to existing"
S TEXT(2)=ENAME_" "_GNAME_" patient data:"
S CODESYS="",NL=2
F S CODESYS=$O(CODESYSL(CODESYS)) Q:CODESYS="" D
. S CODE=""
. F S CODE=$O(CODESYSL(CODESYS,CODE)) Q:CODE="" D
.. S NL=NL+1,TEXT(NL)=" "_CODESYS_" "_CODE
S NL=NL+1,TEXT(NL)=""
D EN^DDIOL(.TEXT)
S VFILENUM=$$ASSOVFILE(FILENUM)
I '$D(^PXRMINDX(VFILENUM,"IP",IEN)) D Q
. K TEXT
. S TEXT(1)=""
. S TEXT(2)="No patients have been given the "_GNAME_": "_ENAME
. S TEXT(3)="there is no data to link."
. D EN^DDIOL(.TEXT) H 3
K DIR
S DIR(0)="YAO",DIR("B")="N"
S DIR("A")="Do you want to link them? "
D ^DIR
I 'Y Q
K DIR
S DIR(0)="DAO^NOW::ERX"
S DIR("A")="When do you want the linking job to start? "
S DIR("B")="NOW"
D ^DIR
I (Y="^")!(Y="") Q
S STARTDT=Y
D TASKLINK(FILENUM,GBL,IEN,.CODESYSL,STARTDT)
Q
;
;==========================================
MCUNLINK(FILENUM,IEN) ;Start a task to unlink mapped codes, called from
;ScreenMan form post-save.
;FILENUM is the file number of the data type file.
;IEN is the internal entry number of the data type.
N DA,DDS,DIR,DIR0,GBL,IENS,STARTDT,NL,TEMP,TEXT,X,Y,UNLINK
I '$D(^TMP($J,"UNLINK")) Q
M UNLINK=^TMP($J,"UNLINK")
K ^TMP($J,"UNLINK")
S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
S GBL=$P(GBL,"(",1)
S TEXT(1)="The following codes have been selected for deletion and unlinking:"
S IENS="",NL=1
F S IENS=$O(UNLINK(FILENUM,IENS)) Q:IENS="" D
. D DA^DILF(IENS,.DA)
. S TEMP=@GBL@(DA(1),210,DA,0)
. S CODESYS=$P(TEMP,U,1)
. S CODE=$P(TEMP,U,2)
. S NL=NL+1,TEXT(NL)=" "_CODESYS_" "_CODE
. D DELMC(FILENUM,CODESYS,CODE,IENS)
S NL=NL+1,TEXT(NL)=""
S NL=NL+1,TEXT(NL)="This process will also check all the deleted code mappings for this entry"
S NL=NL+1,TEXT(NL)="to make sure they are completely unlinked."
D EN^DDIOL(.TEXT)
S STARTDT=$$NOW^XLFDT
D TASKUNLK(FILENUM,IEN,STARTDT)
Q
;
;==========================================
SENDEMSG(SUBJECT,FMMSG,ADDTEXT) ;
N IND,EMSG,FROM,NL,TO
;A FileMan error has occurred and we are sending an error message, so
;cleanup the FileMan error variables.
D CLEAN^DILF
D SETTF(.TO,.FROM)
K ^TMP("PXEMSG",$J)
S NL=1,^TMP("PXEMSG",$J,NL,0)=SUBJECT
I $D(ADDTEXT) D
. S IND=0
. F S IND=$O(ADDTEXT(IND)) Q:IND="" D
.. S NL=NL+1,^TMP("PXEMSG",$J,NL,0)=ADDTEXT(IND)
S NL=NL+1,^TMP("PXEMSG",$J,NL,0)="The following error message was returned by FileMan:"
D ACOPY^PXUTIL("FMMSG","EMSG()")
S IND=0 F S IND=$O(EMSG(IND)) Q:IND="" S NL=NL+1,^TMP("PXEMSG",$J,NL,0)=EMSG(IND)
D SEND^PXMSG("PXEMSG",SUBJECT,.TO,FROM)
K ^TMP("PXEMSG",$J)
Q
;
;==========================================
SETTF(TO,FROM) ;Set the TO and FROM for delivering the MailMan messages.
N MGIEN,MGROUP
S FROM=$$GET1^DIQ(200,DUZ,.01)
S MGIEN=$P($G(^PX(815,1,650)),U,1)
S TO(DUZ)=""
I MGIEN'="" D
. S MGROUP="G."_$$GET1^DIQ(3.8,MGIEN,.01)
. S TO(MGROUP)=""
Q
;
;==========================================
TASKLINK(FILENUM,GBL,IEN,CODESYSL,STARTDT) ;Start a task to link
;mapped codes.
N ZTREQ,ZTSAVE,ZTSK,ZTIO,ZTDTH,ZTRTN
S ZTREQ="@"
S ZTSAVE("FILENUM")=""
S ZTSAVE("GBL")=""
S ZTSAVE("IEN")=""
S ZTSAVE("CODESYSL(")=""
S ZTRTN="TSKLINK^PXMCLINK"
S ZTDESC="Link mapped codes for "_GBL_" IEN="_IEN
S ZTDTH=STARTDT
S ZTIO=""
D ^%ZTLOAD
I ZTSK'="" W !,"Task number ",ZTSK," queued." H 3
Q
;
;==========================================
TASKUNLK(FILENUM,IEN,STARTDT) ;Start a task to unlink mapped codes.
N ZTREQ,ZTSAVE,ZTSK,ZTIO,ZTDTH,ZTRTN
S ZTREQ="@"
S ZTSAVE("IEN")=""
S ZTSAVE("FILENUM")=""
S ZTRTN="TSKUNLK^PXMCLINK"
S ZTDESC="Unlink mapped codes for "_GBL_" IEN="_IEN
S ZTDTH=STARTDT
S ZTIO=""
D ^%ZTLOAD
I ZTSK'="" W !,"Task number ",ZTSK," queued." H 3
Q
;
;==========================================
TSKLINK ;Arguments come through ZTSAVE.
D LINK^PXMCLINK(FILENUM,GBL,IEN,.CODESYSL)
Q
;
;==========================================
TSKUNLK ;Arguments come through ZTSAVE.
D UNLINK^PXMCLINK(FILENUM,IEN)
Q
;
;==========================================
UNLINK(FILENUM,IEN) ;Check for codes that should be unlinked.
;FILENUM is the file number of the data type file.
;IEN is the internal entry number of the data type.
;UNLINK is the list of V-file entries to delete.
N ASSOVFILE,CODE,CODEIEN,CODESYS,DA,ENAME,ERROR,FROM,GBL,GNAME,IENS
N IND,KFDA,MSG,NL,NUMUNL,SCC,SOURCE,SUBJECT,TEMP,TO,UNLINKDT
N VCODFNUM,VSCIEN,ZNODE
S ASSOVFILE=$$ASSOVFILE(FILENUM)
S SOURCE=FILENUM_";"_IEN
S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
S GBL=$P(GBL,"(",1)
S GNAME=$$GET1^DID(FILENUM,"","","NAME")
S ENAME=$P($G(@GBL@(IEN,0)),U,1)
S SUBJECT="Code mapping(s) for "_GNAME_" entry "_ENAME_" have been deleted and unlinked."
K ^TMP("PXXMZ",$J)
S ^TMP("PXXMZ",$J,1,0)=SUBJECT
S ^TMP("PXXMZ",$J,2,0)="The following codes were deleted and unlinked:"
S (ERROR,IND)=0,NL=2,VCODFNUM=9000010.71
F S IND=+$O(@GBL@(IEN,230,IND)) Q:IND=0 D
. S TEMP=@GBL@(IEN,230,IND,0)
.;If there is a MSE Removal Date this entry is already done.
. I $P(TEMP,U,5)'="" Q
. S CODESYS=$P(TEMP,U,1)
. S CODE=$P(TEMP,U,2)
. S ERROR=0
. S NUMUNL=0
. S NL=NL+1,^TMP("PXXMZ",$J,NL,0)=" "_CODESYS_" "_CODE
. S UNLINKDT=$$NOW^XLFDT
. K SCC
. M SCC=^AUPNVSC("SCC",SOURCE,CODESYS,CODE)
. S VSCIEN=""
. F S VSCIEN=$O(SCC(VSCIEN)) Q:VSCIEN="" D
.. S ZNODE=^AUPNVSC(VSCIEN,0)
.. K KFDA,MSG
.. S KFDA(VCODFNUM,VSCIEN_",",.01)="@"
.. D FILE^DIE("","KFDA","MSG")
.. I '$D(DIERR) S NUMUNL=NUMUNL+1 D DELEVENT^PXMCEVNT(VCODFNUM,VSCIEN,ZNODE)
.. I $D(DIERR) D
... S ERROR=1
... S SUBJECT="Mapped code unlinking failed for file #"_FILENUM_", IEN="_IEN_", VSCIEN="_VSCIEN
... D SENDEMSG(SUBJECT,.MSG)
. I 'ERROR D
.. S $P(@GBL@(IEN,230,IND,0),U,5)=UNLINKDT
.. S NL=NL+1,^TMP("PXXMZ",$J,NL,0)=" "_NUMUNL_" V Standard Codes entries were removed."
.. S NL=NL+1,^TMP("PXXMZ",$J,NL,0)=""
I 'ERROR D
. D SETTF(.TO,.FROM)
. D SEND^PXMSG("PXXMZ",SUBJECT,.TO,"PCE MANAGEMENT")
K ^TMP($J,"LIST"),^TMP("PXXMZ",$J)
Q
;
;==========================================
VFDATA(VCODFNUM,ASSOVFILE,IEN,IENS,FDA) ;Load the additional V-file data into
;the FDA.
S FDA(VCODFNUM,IENS,.03)=$$GET1^DIQ(ASSOVFILE,IEN,.03,"I")
S FDA(VCODFNUM,IENS,1201)=$$GET1^DIQ(ASSOVFILE,IEN,1201,"I")
S FDA(VCODFNUM,IENS,1202)=$$GET1^DIQ(ASSOVFILE,IEN,1202,"I")
S FDA(VCODFNUM,IENS,1204)=$$GET1^DIQ(ASSOVFILE,IEN,1204,"I")
S FDA(VCODFNUM,IENS,81202)=$$GET1^DIQ(ASSOVFILE,IEN,81202,"I")
S FDA(VCODFNUM,IENS,81203)=$$GET1^DIQ(ASSOVFILE,IEN,81203,"I")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXMCLINK 13718 printed Oct 16, 2024@18:30:17 Page 2
PXMCLINK ;SLC/PKR - Mapped codes linking and unlinking routines. ;02/20/2019
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**211**;Aug 12, 1996;Build 454
+2 ;
+3 ;==========================================
ASSOVFILE(FILENUM) ;Given a PCE data type file number return the associated
+1 ;V file number.
+2 QUIT $SELECT(FILENUM=9999999.09:9000010.16,FILENUM=9999999.15:9000010.13,FILENUM=9999999.64:9000010.23,1:"")
+3 ;
+4 ;==========================================
CSCLIST(GBL,IEN,CODESYSL) ;Populate the coding system code list.
+1 NEW CODE,COESYS,IND,TEMP
+2 KILL CODESYSL
+3 SET IND=0
+4 FOR
SET IND=+$ORDER(@GBL@(IEN,210,IND))
if IND=0
QUIT
Begin DoDot:1
+5 SET TEMP=@GBL@(IEN,210,IND,0)
+6 ;Skip if there already is a Date Linked.
+7 IF $PIECE(TEMP,U,4)'=""
QUIT
+8 SET CODESYS=$PIECE(TEMP,U,1)
SET CODE=$PIECE(TEMP,U,2)
+9 IF CODE'=""
SET CODESYSL(CODESYS,CODE)=IND
End DoDot:1
+10 QUIT
+11 ;
+12 ;==========================================
DELCHK(CODESYSL) ;When there are mappings that are being deleted,
+1 ;if they are also on the list to link remove them from the list to
+2 ;link.
+3 NEW CODE,CODESYS,DA,GBL,IENS,TEMP,UNLINK
+4 MERGE UNLINK=^TMP($JOB,"UNLINK")
+5 SET GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
+6 SET GBL=$PIECE(GBL,"(",1)
+7 SET IENS=""
+8 FOR
SET IENS=$ORDER(UNLINK(FILENUM,IENS))
if IENS=""
QUIT
Begin DoDot:1
+9 DO DA^DILF(IENS,.DA)
+10 SET TEMP=@GBL@(DA(1),210,DA,0)
+11 SET CODESYS=$PIECE(TEMP,U,1)
+12 SET CODE=$PIECE(TEMP,U,2)
+13 KILL CODESYSL(CODESYS,CODE)
End DoDot:1
+14 QUIT
+15 ;
+16 ;==========================================
DELMC(FILENUM,CODESYS,CODE,IENS) ;Delete a mapped code.
+1 ;Before deletion save the mapped code in the Deleted Code Mappings
+2 ;multiple.
+3 NEW ADDIENS,CMSFN,DCMSFN,FDA,KFDA,IEN,MSG,SUBJECT
+4 SET IEN=$PIECE(IENS,",",2)
+5 SET ADDIENS="+1,"_IEN_","
+6 SET DCMSFN=+$$GET1^DID(FILENUM,"DELETED CODE MAPPINGS","","SPECIFIER")
+7 SET FDA(DCMSFN,ADDIENS,.01)=CODESYS
+8 SET FDA(DCMSFN,ADDIENS,1)=CODE
+9 SET FDA(DCMSFN,ADDIENS,2)=$$NOW^XLFDT
+10 SET FDA(DCMSFN,ADDIENS,3)=DUZ
+11 DO UPDATE^DIE("","FDA","","MSG")
+12 IF $DATA(DIERR)
Begin DoDot:1
+13 NEW TEXT
+14 SET TEXT(1)="IENS="_IENS
+15 SET TEXT(2)="CODESYS="_CODESYS_", CODE="_CODE
+16 SET SUBJECT="Mapped code copy before deletion failed for file #"_FILENUM
+17 DO SENDEMSG(SUBJECT,.MSG,.TEXT)
End DoDot:1
QUIT
+18 SET CMSFN=+$$GET1^DID(FILENUM,"CODE MAPPINGS","","SPECIFIER")
+19 SET KFDA(CMSFN,IENS,.01)="@"
+20 DO FILE^DIE("","KFDA","MSG")
+21 IF $DATA(DIERR)
Begin DoDot:1
+22 NEW TEXT
+23 SET TEXT(1)="IENS="_IENS
+24 SET TEXT(2)="CODESYS="_CODESYS_", CODE="_CODE
+25 SET SUBJECT="Mapped code deletion failed for file #"_FILENUM
+26 DO SENDEMSG(SUBJECT,.MSG,.TEXT)
End DoDot:1
QUIT
+27 QUIT
+28 ;
+29 ;==========================================
LINK(FILENUM,GBL,IEN,CODESYSL) ;Create entries in V Standard Codes file for
+1 ;legacy data that has been mapped to standard codes and link them
+2 ;through the Mapped Source field.
+3 ;FILENUM is the file number of the data type file.
+4 ;GBL is the corresponding global
+5 ;IEN is the internal entry number of the data type.
+6 ;CODESYSL is the list of mapped codes: (CODESYS,CODE)
+7 NEW ASSOVFILE,CODE,CODEDT,CODEIEN,CODESYS,DAS,DATE,DFN,ERROR,FDA,FDAIEN
+8 NEW FROM,IENS,IND,MSG,MSOURCE,NUMLINK,NL,SUBJECT,TO
+9 NEW VCODFNUM,VFDATA,VISITIEN
+10 KILL ^TMP("PXXMZ",$JOB)
+11 SET ASSOVFILE=$$ASSOVFILE(FILENUM)
+12 IF '$DATA(^PXRMINDX(ASSOVFILE,"IP",IEN))
QUIT
+13 SET MSOURCE=FILENUM_";"_IEN
+14 SET IENS="+1,"
+15 SET CODESYS=""
SET NL=2
+16 SET VCODFNUM=9000010.71
+17 FOR
SET CODESYS=$ORDER(CODESYSL(CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+18 KILL FDA
+19 SET FDA(VCODFNUM,IENS,300)=MSOURCE
+20 SET FDA(VCODFNUM,IENS,.05)=CODESYS
+21 SET CODE=""
+22 FOR
SET CODE=$ORDER(CODESYSL(CODESYS,CODE))
if CODE=""
QUIT
Begin DoDot:2
+23 SET NUMLINK(CODESYS,CODE)=0
+24 SET FDA(VCODFNUM,IENS,.01)=CODE
+25 SET DFN=""
+26 FOR
SET DFN=$ORDER(^PXRMINDX(ASSOVFILE,"IP",IEN,DFN))
if DFN=""
QUIT
Begin DoDot:3
+27 SET ERROR=0
+28 SET FDA(VCODFNUM,IENS,.02)=DFN
+29 SET DATE=""
+30 FOR
SET DATE=$ORDER(^PXRMINDX(ASSOVFILE,"IP",IEN,DFN,DATE))
if DATE=""
QUIT
Begin DoDot:4
+31 SET DAS=""
+32 FOR
SET DAS=$ORDER(^PXRMINDX(ASSOVFILE,"IP",IEN,DFN,DATE,DAS))
if DAS=""
QUIT
Begin DoDot:5
+33 DO VFDATA(VCODFNUM,ASSOVFILE,DAS,IENS,.FDA)
+34 ;If the code is a duplicate do not add it.
+35 SET VISITIEN=FDA(VCODFNUM,IENS,.03)
+36 SET CODEDT=FDA(VCODFNUM,IENS,1201)
+37 IF CODEDT=""
SET CODEDT=$PIECE(^AUPNVSIT(VISITIEN,0),U,1)
+38 IF $$VSCDUP^PXKMCODE(CODESYS,CODE,VISITIEN,CODEDT,MSOURCE)
QUIT
+39 KILL FDAIEN,MSG
+40 DO UPDATE^DIE("S","FDA","FDAIEN","MSG")
+41 IF $DATA(DIERR)
Begin DoDot:6
+42 SET ERROR=1
+43 SET SUBJECT="Mapped code linking failed for file #"_FILENUM_", IEN="_IEN_", DFN="_DFN
+44 DO SENDEMSG(SUBJECT,.MSG)
End DoDot:6
QUIT
+45 SET NUMLINK(CODESYS,CODE)=NUMLINK(CODESYS,CODE)+1
+46 ;Fire PXK VISIT DATA EVENT for the addition of a code.
+47 DO ADDEVENT^PXMCEVNT(VCODFNUM,FDAIEN(1))
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+48 IF ERROR
KILL ^TMP("PXXMZ",$JOB)
QUIT
+49 NEW ENAME,GNAME,LINKDT
+50 DO SETTF(.TO,.FROM)
+51 SET GNAME=$$GET1^DID(FILENUM,"","","NAME")
+52 SET ENAME=$PIECE($GET(@GBL@(IEN,0)),U,1)
+53 SET SUBJECT=GNAME_" entry "_ENAME_" has been linked."
+54 SET LINKDT=$$NOW^XLFDT
+55 SET ^TMP("PXXMZ",$JOB,1,0)="Linking completed at "_$$FMTE^XLFDT(LINKDT,"5Z")
+56 SET ^TMP("PXXMZ",$JOB,2,0)="The following codes were linked:"
+57 SET CODESYS=""
+58 FOR
SET CODESYS=$ORDER(CODESYSL(CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+59 SET CODE=""
+60 FOR
SET CODE=$ORDER(CODESYSL(CODESYS,CODE))
if CODE=""
QUIT
Begin DoDot:2
+61 ;Set the Date Linked.
+62 SET IND=CODESYSL(CODESYS,CODE)
+63 SET $PIECE(@GBL@(IEN,210,IND,0),U,4)=LINKDT
+64 SET NL=NL+1
SET ^TMP("PXXMZ",$JOB,NL,0)=" "_CODESYS_": "_CODE
+65 IF NUMLINK(CODESYS,CODE)>0
Begin DoDot:3
+66 SET NL=NL+1
SET ^TMP("PXXMZ",$JOB,NL,0)=" There were "_NUMLINK(CODESYS,CODE)_" instances where the code was linked."
End DoDot:3
+67 SET NL=NL+1
SET ^TMP("PXXMZ",$JOB,NL,0)=""
End DoDot:2
End DoDot:1
+68 DO SEND^PXMSG("PXXMZ",SUBJECT,.TO,FROM)
+69 KILL ^TMP("PXXMZ",$JOB)
+70 QUIT
+71 ;
+72 ;==========================================
LINKALL ;Link all national exams, education topics, and health factors
+1 ;that have been mapped.
+2 NEW CLASS,IEN,FILENUM,GBL,GNAME,NL,NMAPPED,TEXT
+3 KILL ^TMP("PXXMZ",$JOB)
+4 SET NL=1
+5 FOR FILENUM=9999999.09,9999999.15,9999999.64
Begin DoDot:1
+6 SET GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
+7 SET GBL=$PIECE(GBL,"(",1)
+8 SET GNAME=$$GET1^DID(FILENUM,"","","NAME")
+9 SET NL=NL+1
SET ^TMP("PXXMZ",$JOB,NL,0)=""
+10 SET NL=NL+1
SET ^TMP("PXXMZ",$JOB,NL,0)="Linking national "_GNAME_" that have been mapped."
+11 SET IEN=0
+12 FOR
SET IEN=+$ORDER(@GBL@(IEN))
if IEN=0
QUIT
Begin DoDot:2
+13 SET NMAPPED=+$PIECE($GET(@GBL@(IEN,210,0)),U,4)
+14 IF NMAPPED=0
QUIT
+15 SET CLASS=$PIECE(@GBL@(IEN,100),U,1)
+16 IF CLASS'="N"
QUIT
+17 SET NL=NL+1
SET ^TMP("PXXMZ",$JOB,NL,0)=" Linking "_GNAME_": "_$PIECE(@GBL@(IEN,0),U,1)
+18 DO CSCLIST^PXMCLINK(GBL,IEN,.CODESYSL)
+19 IF '$DATA(CODESYSL)
QUIT
+20 DO LINK^PXMCLINK(FILENUM,GBL,IEN,CODESYSL,0)
End DoDot:2
End DoDot:1
+21 DO SEND^PXMSG("PXXMZ","LINKING NATIONAL PCE ENTRIES",DUZ,"PCE")
+22 KILL ^TMP("PXXMZ",$JOB)
+23 QUIT
+24 ;
+25 ;==========================================
MCLINK(FILENUM,IEN) ;Check for codes that have been mapped but not linked,
+1 ;called from ScreenMan form post-save.
+2 ;It there are any, ask the user if they want to link them.
+3 NEW CODE,CODESYS,CODESYSL,DDS,DIR,DIR0,ENAME,GBL,GNAME,NL,NMAPPED
+4 NEW STARTDT,TEMP,TEXT,VFILENUM,X,Y
+5 SET GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
+6 SET GBL=$PIECE(GBL,"(",1)
+7 SET NMAPPED=+$PIECE($GET(@GBL@(IEN,210,0)),U,4)
+8 IF NMAPPED=0
QUIT
+9 SET GNAME=$$GET1^DID(FILENUM,"","","NAME")
+10 SET ENAME=$PIECE($GET(@GBL@(IEN,0)),U,1)
+11 DO CSCLIST^PXMCLINK(GBL,IEN,.CODESYSL)
+12 IF $DATA(^TMP($JOB,"UNLINK",FILENUM))
DO DELCHK(.CODESYSL)
+13 IF '$DATA(CODESYSL)
QUIT
+14 SET TEXT(1)="The following codes have been mapped but not linked to existing"
+15 SET TEXT(2)=ENAME_" "_GNAME_" patient data:"
+16 SET CODESYS=""
SET NL=2
+17 FOR
SET CODESYS=$ORDER(CODESYSL(CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+18 SET CODE=""
+19 FOR
SET CODE=$ORDER(CODESYSL(CODESYS,CODE))
if CODE=""
QUIT
Begin DoDot:2
+20 SET NL=NL+1
SET TEXT(NL)=" "_CODESYS_" "_CODE
End DoDot:2
End DoDot:1
+21 SET NL=NL+1
SET TEXT(NL)=""
+22 DO EN^DDIOL(.TEXT)
+23 SET VFILENUM=$$ASSOVFILE(FILENUM)
+24 IF '$DATA(^PXRMINDX(VFILENUM,"IP",IEN))
Begin DoDot:1
+25 KILL TEXT
+26 SET TEXT(1)=""
+27 SET TEXT(2)="No patients have been given the "_GNAME_": "_ENAME
+28 SET TEXT(3)="there is no data to link."
+29 DO EN^DDIOL(.TEXT)
HANG 3
End DoDot:1
QUIT
+30 KILL DIR
+31 SET DIR(0)="YAO"
SET DIR("B")="N"
+32 SET DIR("A")="Do you want to link them? "
+33 DO ^DIR
+34 IF 'Y
QUIT
+35 KILL DIR
+36 SET DIR(0)="DAO^NOW::ERX"
+37 SET DIR("A")="When do you want the linking job to start? "
+38 SET DIR("B")="NOW"
+39 DO ^DIR
+40 IF (Y="^")!(Y="")
QUIT
+41 SET STARTDT=Y
+42 DO TASKLINK(FILENUM,GBL,IEN,.CODESYSL,STARTDT)
+43 QUIT
+44 ;
+45 ;==========================================
MCUNLINK(FILENUM,IEN) ;Start a task to unlink mapped codes, called from
+1 ;ScreenMan form post-save.
+2 ;FILENUM is the file number of the data type file.
+3 ;IEN is the internal entry number of the data type.
+4 NEW DA,DDS,DIR,DIR0,GBL,IENS,STARTDT,NL,TEMP,TEXT,X,Y,UNLINK
+5 IF '$DATA(^TMP($JOB,"UNLINK"))
QUIT
+6 MERGE UNLINK=^TMP($JOB,"UNLINK")
+7 KILL ^TMP($JOB,"UNLINK")
+8 SET GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
+9 SET GBL=$PIECE(GBL,"(",1)
+10 SET TEXT(1)="The following codes have been selected for deletion and unlinking:"
+11 SET IENS=""
SET NL=1
+12 FOR
SET IENS=$ORDER(UNLINK(FILENUM,IENS))
if IENS=""
QUIT
Begin DoDot:1
+13 DO DA^DILF(IENS,.DA)
+14 SET TEMP=@GBL@(DA(1),210,DA,0)
+15 SET CODESYS=$PIECE(TEMP,U,1)
+16 SET CODE=$PIECE(TEMP,U,2)
+17 SET NL=NL+1
SET TEXT(NL)=" "_CODESYS_" "_CODE
+18 DO DELMC(FILENUM,CODESYS,CODE,IENS)
End DoDot:1
+19 SET NL=NL+1
SET TEXT(NL)=""
+20 SET NL=NL+1
SET TEXT(NL)="This process will also check all the deleted code mappings for this entry"
+21 SET NL=NL+1
SET TEXT(NL)="to make sure they are completely unlinked."
+22 DO EN^DDIOL(.TEXT)
+23 SET STARTDT=$$NOW^XLFDT
+24 DO TASKUNLK(FILENUM,IEN,STARTDT)
+25 QUIT
+26 ;
+27 ;==========================================
SENDEMSG(SUBJECT,FMMSG,ADDTEXT) ;
+1 NEW IND,EMSG,FROM,NL,TO
+2 ;A FileMan error has occurred and we are sending an error message, so
+3 ;cleanup the FileMan error variables.
+4 DO CLEAN^DILF
+5 DO SETTF(.TO,.FROM)
+6 KILL ^TMP("PXEMSG",$JOB)
+7 SET NL=1
SET ^TMP("PXEMSG",$JOB,NL,0)=SUBJECT
+8 IF $DATA(ADDTEXT)
Begin DoDot:1
+9 SET IND=0
+10 FOR
SET IND=$ORDER(ADDTEXT(IND))
if IND=""
QUIT
Begin DoDot:2
+11 SET NL=NL+1
SET ^TMP("PXEMSG",$JOB,NL,0)=ADDTEXT(IND)
End DoDot:2
End DoDot:1
+12 SET NL=NL+1
SET ^TMP("PXEMSG",$JOB,NL,0)="The following error message was returned by FileMan:"
+13 DO ACOPY^PXUTIL("FMMSG","EMSG()")
+14 SET IND=0
FOR
SET IND=$ORDER(EMSG(IND))
if IND=""
QUIT
SET NL=NL+1
SET ^TMP("PXEMSG",$JOB,NL,0)=EMSG(IND)
+15 DO SEND^PXMSG("PXEMSG",SUBJECT,.TO,FROM)
+16 KILL ^TMP("PXEMSG",$JOB)
+17 QUIT
+18 ;
+19 ;==========================================
SETTF(TO,FROM) ;Set the TO and FROM for delivering the MailMan messages.
+1 NEW MGIEN,MGROUP
+2 SET FROM=$$GET1^DIQ(200,DUZ,.01)
+3 SET MGIEN=$PIECE($GET(^PX(815,1,650)),U,1)
+4 SET TO(DUZ)=""
+5 IF MGIEN'=""
Begin DoDot:1
+6 SET MGROUP="G."_$$GET1^DIQ(3.8,MGIEN,.01)
+7 SET TO(MGROUP)=""
End DoDot:1
+8 QUIT
+9 ;
+10 ;==========================================
TASKLINK(FILENUM,GBL,IEN,CODESYSL,STARTDT) ;Start a task to link
+1 ;mapped codes.
+2 NEW ZTREQ,ZTSAVE,ZTSK,ZTIO,ZTDTH,ZTRTN
+3 SET ZTREQ="@"
+4 SET ZTSAVE("FILENUM")=""
+5 SET ZTSAVE("GBL")=""
+6 SET ZTSAVE("IEN")=""
+7 SET ZTSAVE("CODESYSL(")=""
+8 SET ZTRTN="TSKLINK^PXMCLINK"
+9 SET ZTDESC="Link mapped codes for "_GBL_" IEN="_IEN
+10 SET ZTDTH=STARTDT
+11 SET ZTIO=""
+12 DO ^%ZTLOAD
+13 IF ZTSK'=""
WRITE !,"Task number ",ZTSK," queued."
HANG 3
+14 QUIT
+15 ;
+16 ;==========================================
TASKUNLK(FILENUM,IEN,STARTDT) ;Start a task to unlink mapped codes.
+1 NEW ZTREQ,ZTSAVE,ZTSK,ZTIO,ZTDTH,ZTRTN
+2 SET ZTREQ="@"
+3 SET ZTSAVE("IEN")=""
+4 SET ZTSAVE("FILENUM")=""
+5 SET ZTRTN="TSKUNLK^PXMCLINK"
+6 SET ZTDESC="Unlink mapped codes for "_GBL_" IEN="_IEN
+7 SET ZTDTH=STARTDT
+8 SET ZTIO=""
+9 DO ^%ZTLOAD
+10 IF ZTSK'=""
WRITE !,"Task number ",ZTSK," queued."
HANG 3
+11 QUIT
+12 ;
+13 ;==========================================
TSKLINK ;Arguments come through ZTSAVE.
+1 DO LINK^PXMCLINK(FILENUM,GBL,IEN,.CODESYSL)
+2 QUIT
+3 ;
+4 ;==========================================
TSKUNLK ;Arguments come through ZTSAVE.
+1 DO UNLINK^PXMCLINK(FILENUM,IEN)
+2 QUIT
+3 ;
+4 ;==========================================
UNLINK(FILENUM,IEN) ;Check for codes that should be unlinked.
+1 ;FILENUM is the file number of the data type file.
+2 ;IEN is the internal entry number of the data type.
+3 ;UNLINK is the list of V-file entries to delete.
+4 NEW ASSOVFILE,CODE,CODEIEN,CODESYS,DA,ENAME,ERROR,FROM,GBL,GNAME,IENS
+5 NEW IND,KFDA,MSG,NL,NUMUNL,SCC,SOURCE,SUBJECT,TEMP,TO,UNLINKDT
+6 NEW VCODFNUM,VSCIEN,ZNODE
+7 SET ASSOVFILE=$$ASSOVFILE(FILENUM)
+8 SET SOURCE=FILENUM_";"_IEN
+9 SET GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
+10 SET GBL=$PIECE(GBL,"(",1)
+11 SET GNAME=$$GET1^DID(FILENUM,"","","NAME")
+12 SET ENAME=$PIECE($GET(@GBL@(IEN,0)),U,1)
+13 SET SUBJECT="Code mapping(s) for "_GNAME_" entry "_ENAME_" have been deleted and unlinked."
+14 KILL ^TMP("PXXMZ",$JOB)
+15 SET ^TMP("PXXMZ",$JOB,1,0)=SUBJECT
+16 SET ^TMP("PXXMZ",$JOB,2,0)="The following codes were deleted and unlinked:"
+17 SET (ERROR,IND)=0
SET NL=2
SET VCODFNUM=9000010.71
+18 FOR
SET IND=+$ORDER(@GBL@(IEN,230,IND))
if IND=0
QUIT
Begin DoDot:1
+19 SET TEMP=@GBL@(IEN,230,IND,0)
+20 ;If there is a MSE Removal Date this entry is already done.
+21 IF $PIECE(TEMP,U,5)'=""
QUIT
+22 SET CODESYS=$PIECE(TEMP,U,1)
+23 SET CODE=$PIECE(TEMP,U,2)
+24 SET ERROR=0
+25 SET NUMUNL=0
+26 SET NL=NL+1
SET ^TMP("PXXMZ",$JOB,NL,0)=" "_CODESYS_" "_CODE
+27 SET UNLINKDT=$$NOW^XLFDT
+28 KILL SCC
+29 MERGE SCC=^AUPNVSC("SCC",SOURCE,CODESYS,CODE)
+30 SET VSCIEN=""
+31 FOR
SET VSCIEN=$ORDER(SCC(VSCIEN))
if VSCIEN=""
QUIT
Begin DoDot:2
+32 SET ZNODE=^AUPNVSC(VSCIEN,0)
+33 KILL KFDA,MSG
+34 SET KFDA(VCODFNUM,VSCIEN_",",.01)="@"
+35 DO FILE^DIE("","KFDA","MSG")
+36 IF '$DATA(DIERR)
SET NUMUNL=NUMUNL+1
DO DELEVENT^PXMCEVNT(VCODFNUM,VSCIEN,ZNODE)
+37 IF $DATA(DIERR)
Begin DoDot:3
+38 SET ERROR=1
+39 SET SUBJECT="Mapped code unlinking failed for file #"_FILENUM_", IEN="_IEN_", VSCIEN="_VSCIEN
+40 DO SENDEMSG(SUBJECT,.MSG)
End DoDot:3
End DoDot:2
+41 IF 'ERROR
Begin DoDot:2
+42 SET $PIECE(@GBL@(IEN,230,IND,0),U,5)=UNLINKDT
+43 SET NL=NL+1
SET ^TMP("PXXMZ",$JOB,NL,0)=" "_NUMUNL_" V Standard Codes entries were removed."
+44 SET NL=NL+1
SET ^TMP("PXXMZ",$JOB,NL,0)=""
End DoDot:2
End DoDot:1
+45 IF 'ERROR
Begin DoDot:1
+46 DO SETTF(.TO,.FROM)
+47 DO SEND^PXMSG("PXXMZ",SUBJECT,.TO,"PCE MANAGEMENT")
End DoDot:1
+48 KILL ^TMP($JOB,"LIST"),^TMP("PXXMZ",$JOB)
+49 QUIT
+50 ;
+51 ;==========================================
VFDATA(VCODFNUM,ASSOVFILE,IEN,IENS,FDA) ;Load the additional V-file data into
+1 ;the FDA.
+2 SET FDA(VCODFNUM,IENS,.03)=$$GET1^DIQ(ASSOVFILE,IEN,.03,"I")
+3 SET FDA(VCODFNUM,IENS,1201)=$$GET1^DIQ(ASSOVFILE,IEN,1201,"I")
+4 SET FDA(VCODFNUM,IENS,1202)=$$GET1^DIQ(ASSOVFILE,IEN,1202,"I")
+5 SET FDA(VCODFNUM,IENS,1204)=$$GET1^DIQ(ASSOVFILE,IEN,1204,"I")
+6 SET FDA(VCODFNUM,IENS,81202)=$$GET1^DIQ(ASSOVFILE,IEN,81202,"I")
+7 SET FDA(VCODFNUM,IENS,81203)=$$GET1^DIQ(ASSOVFILE,IEN,81203,"I")
+8 QUIT
+9 ;
