- 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 Jan 18, 2025@03:30:40 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 ;