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

DGPTDDCR.m

Go to the documentation of this file.
  1. DGPTDDCR ;SLC/PKR,ALB/KCL - Routines for setting and killing Clinical Reminders Index. ;5/11/2015
  1. ;;5.3;Registration;**478,862,884**;Aug 13, 1993;Build 31
  1. ;=============================================
  1. ;The structure of the Index is:
  1. ; ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE/TIME,DAS)
  1. ; ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE/TIME,DAS)
  1. ;where code is the actual code and not a pointer.
  1. ;
  1. ;DBIA #4114 covers setting and killing of ^PXRMINDX(45).
  1. ;DBIA #4521 covers use of INDEX entry point to build
  1. ;the Clinical Reminders Index for the PTF (#45) file.
  1. ;DBIA #5679 covers references to ^LEXU entry points.
  1. ;DBIA #5747 covers references to ^ICDEX entry points.
  1. ;
  1. ;=============================================
  1. INDEX ;Build all the indexes for PTF.
  1. N ADMDT,CC,CODE,CODEP,CODESYS,D1,DA,DAS,DATE,DFN,END,ENTRIES,ETEXT
  1. N GLOBAL,IND,JND,KND,NERROR,NODE,START
  1. N TEMP0,TEMP70,TEMP71,TEMPP,TEMPS,TENP,TEXT,TOTAL
  1. ;DBIA #4114
  1. ;Don't leave any old stuff around.
  1. K ^PXRMINDX(45)
  1. S GLOBAL=$$GET1^DID(45,"","","GLOBAL NAME")
  1. S ENTRIES=$P(^DGPT(0),U,4)
  1. S TENP=ENTRIES/10
  1. S TENP=+$P(TENP,".",1)
  1. I TENP<1 S TENP=1
  1. D BMES^XPDUTL("Building indexes for DGPT")
  1. S TEXT="There are "_ENTRIES_" entries to process."
  1. D MES^XPDUTL(TEXT)
  1. S START=$H
  1. ;Initialize the ICD coding system variable.
  1. S CODESYS=""
  1. ;DBIA #5679
  1. F S CODESYS=$$NXSAB^LEXU(CODESYS,0) Q:CODESYS="" I $P($$CSYS^LEXU(CODESYS),U,4)["ICD" S CC(CODESYS)=0
  1. S (DA,IND,NERROR)=0
  1. F S DA=+$O(^DGPT(DA)) Q:DA=0 D
  1. .;Make sure the 0 node is defined.
  1. . I '$D(^DGPT(DA,0)) D Q
  1. .. S ETEXT="IEN "_DA_" is missing the 0 node."
  1. .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1. .;Save the admission date.
  1. . S ADMDT=$P(^DGPT(DA,0),U,2)
  1. . I ADMDT="" D Q
  1. .. S ETEXT="IEN "_DA_" is missing the Admission Date which is a required field."
  1. .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1. . S IND=IND+1
  1. . I IND#TENP=0 D
  1. .. S TEXT="Processing entry "_IND
  1. .. D MES^XPDUTL(TEXT)
  1. . I IND#10000=0 W "."
  1. . S TEMP0=$G(^DGPT(DA,0))
  1. .;Census records are not indexed.
  1. . I $P(TEMP0,U,11)=2 Q
  1. . S DFN=$P(TEMP0,U,1)
  1. . I DFN="" D Q
  1. .. S ETEXT=DA_" no patient"
  1. .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1. .;Check the surgery nodes.
  1. . S D1=0
  1. .;loop thru surgeries on zero node
  1. . F S D1=+$O(^DGPT(DA,"S",D1)) Q:D1=0 D
  1. .. S TEMPS=$G(^DGPT(DA,"S",D1,0))
  1. .. S DATE=$P(TEMPS,U,1)
  1. .. I DATE="" D Q
  1. ... S ETEXT=DA_" S node missing date"
  1. ... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
  1. .. S DAS=DA_";S;"_D1_";0"
  1. .. S KND=0
  1. .. F JND=8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27 D
  1. ... S KND=KND+1
  1. ... S CODEP=$P(TEMPS,U,JND)
  1. ... I CODEP="" Q
  1. ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80.1,CODEP)),U,3)
  1. ... S CODE=$$CODEC^ICDEX(80.1,CODEP)
  1. ... I $P(CODE,U,1)=-1 D Q
  1. .... S ETEXT=DAS_" has the invalid code "_CODE
  1. .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1. ... S CC(CODESYS)=CC(CODESYS)+1
  1. ... S NODE="S"_KND
  1. ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
  1. ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
  1. .;
  1. .;Begin block of code for 401 Operation Code 21 field through Operation Code 25 field.
  1. . N DGDATA,DGPIECE
  1. . S D1=0
  1. .;loop thru surgeries on one node
  1. . F S D1=+$O(^DGPT(DA,"S",D1)) Q:D1=0 D
  1. .. S TEMPS=$G(^DGPT(DA,"S",D1,1)) ;Operation Code 21-25
  1. .. S DGDATA=0
  1. .. F DGPIECE=1:1:5 I +$P(TEMPS,U,DGPIECE) S DGDATA=1
  1. .. Q:'$G(DGDATA) ;quit if no data on the node
  1. .. S DATE=+$G(^DGPT(DA,"S",D1,0)) ;Surgery/Procedure Date
  1. .. I DATE=0 D Q
  1. ... S ETEXT=DA_" S node missing date"
  1. ... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
  1. .. S DAS=DA_";S;"_D1_";1"
  1. .. S KND=20
  1. .. F JND=1,2,3,4,5 D
  1. ... S KND=KND+1
  1. ... S CODEP=$P(TEMPS,U,JND)
  1. ... I CODEP="" Q
  1. ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80.1,CODEP)),U,3)
  1. ... S CODE=$$CODEC^ICDEX(80.1,CODEP)
  1. ... I $P(CODE,U,1)=-1 D Q
  1. .... S ETEXT=DAS_" has the invalid code "_CODE
  1. .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1. ... S CC(CODESYS)=CC(CODESYS)+1
  1. ... S NODE="S"_KND
  1. ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
  1. ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
  1. .;End block of code for 401 Operation Code 21 field through Operation Code 25 field.
  1. .;
  1. .;Check the procedure nodes.
  1. . S D1=0
  1. .;loop thru procedures on zero node
  1. . F S D1=+$O(^DGPT(DA,"P",D1)) Q:D1=0 D
  1. .. S TEMPP=$G(^DGPT(DA,"P",D1,0))
  1. .. S DATE=$P(TEMPP,U,1)
  1. .. I DATE="" D Q
  1. ... S ETEXT=DA_" P node missing date"
  1. ... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
  1. .. S DAS=DA_";P;"_D1_";0"
  1. .. S KND=0
  1. .. F JND=5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24 D
  1. ... S KND=KND+1
  1. ... S CODEP=$P(TEMPP,U,JND)
  1. ... I CODEP="" Q
  1. ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80.1,CODEP)),U,3)
  1. ... S CODE=$$CODEC^ICDEX(80.1,CODEP)
  1. ... I $P(CODE,U,1)=-1 D Q
  1. .... S ETEXT=DAS_" has the invalid code "_CODE
  1. .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1. ... S CC(CODESYS)=CC(CODESYS)+1
  1. ... S NODE="P"_KND
  1. ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
  1. ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
  1. .;
  1. .;Begin block of code for 601 Procedure Code fields ICD 21 through ICD 25.
  1. . N DGDATA,DGPIECE
  1. . S D1=0
  1. .;loop thru procedures on one node
  1. . F S D1=+$O(^DGPT(DA,"P",D1)) Q:D1=0 D
  1. .. S TEMPP=$G(^DGPT(DA,"P",D1,1)) ;ICD 21 through ICD 25
  1. .. S DGDATA=0
  1. .. F DGPIECE=1:1:5 I +$P(TEMPP,U,DGPIECE) S DGDATA=1
  1. .. Q:'$G(DGDATA) ;quit if no data on the node
  1. .. S DATE=+$G(^DGPT(DA,"P",D1,0)) ;Procedure Date
  1. .. I DATE=0 D Q
  1. ... S ETEXT=DA_" P node missing date"
  1. ... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
  1. .. S DAS=DA_";P;"_D1_";1"
  1. .. S KND=20
  1. .. F JND=1,2,3,4,5 D
  1. ... S KND=KND+1
  1. ... S CODEP=$P(TEMPP,U,JND)
  1. ... I CODEP="" Q
  1. ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80.1,CODEP)),U,3)
  1. ... S CODE=$$CODEC^ICDEX(80.1,CODEP)
  1. ... I $P(CODE,U,1)=-1 D Q
  1. .... S ETEXT=DAS_" has the invalid code "_CODE
  1. .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1. ... S CC(CODESYS)=CC(CODESYS)+1
  1. ... S NODE="P"_KND
  1. ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
  1. ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
  1. .;End block of code for 601 Procedure Code fields ICD 21 through ICD 25.
  1. .;
  1. .;Discharge ICD codes
  1. . I $D(^DGPT(DA,70)) D
  1. .. S TEMP70=$G(^DGPT(DA,70))
  1. .. S TEMP71=$G(^DGPT(DA,71))
  1. .. S DATE=$P(TEMP70,U,1)
  1. .. I DATE="" S DATE=$P(TEMP0,U,2)
  1. .. S DAS=DA_";70"
  1. .. S CODEP=$P(TEMP70,U,10)
  1. .. I CODEP'="" D
  1. ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
  1. ... S CODE=$$CODEC^ICDEX(80,CODEP)
  1. ... I $P(CODE,U,1)=-1 D Q
  1. .... S ETEXT=DAS_" DXLS has the invalid code "_CODE
  1. .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1. ... E D
  1. .... S CC(CODESYS)=CC(CODESYS)+1
  1. .... S ^PXRMINDX(45,CODESYS,"INP",CODE,"DXLS",DFN,DATE,DAS)=""
  1. .... S ^PXRMINDX(45,CODESYS,"PNI",DFN,"DXLS",CODE,DATE,DAS)=""
  1. ..;
  1. .. S CODEP=$P(TEMP70,U,11)
  1. .. I CODEP'="" D
  1. ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
  1. ... S CODE=$$CODEC^ICDEX(80,CODEP)
  1. ... I $P(CODE,U,1)=-1 D Q
  1. .... S ETEXT=DAS_" PDX has the invalid code "_CODE
  1. .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1. ... E D
  1. .... S CC(CODESYS)=CC(CODESYS)+1
  1. .... S ^PXRMINDX(45,CODESYS,"INP",CODE,"PDX",DFN,DATE,DAS)=""
  1. .... S ^PXRMINDX(45,CODESYS,"PNI",DFN,"PDX",CODE,DATE,DAS)=""
  1. ..;
  1. ..;70 node secondary diagnosis
  1. .. S KND=0
  1. .. F JND=16,17,18,19,20,21,22,23,24 D
  1. ... S KND=KND+1
  1. ... S CODEP=$P(TEMP70,U,JND)
  1. ... I CODEP="" Q
  1. ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
  1. ... S CODE=$$CODEC^ICDEX(80,CODEP)
  1. ... I $P(CODE,U,1)=-1 D Q
  1. .... S ETEXT=DAS_" node has the invalid code "_CODE
  1. .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1. ... S CC(CODESYS)=CC(CODESYS)+1
  1. ... S NODE="D SD"_KND
  1. ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
  1. ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
  1. ..;
  1. ..;71 node secondary diagnosis
  1. .. S DAS=DA_";71"
  1. .. S KND=9
  1. .. F JND=1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 D
  1. ... S KND=KND+1
  1. ... S CODEP=$P(TEMP71,U,JND)
  1. ... I CODEP="" Q
  1. ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
  1. ... S CODE=$$CODEC^ICDEX(80,CODEP)
  1. ... I $P(CODE,U,1)=-1 D Q
  1. .... S ETEXT=DAS_" node has the invalid code "_CODE
  1. .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1. ... S CC(CODESYS)=CC(CODESYS)+1
  1. ... S NODE="D SD"_KND
  1. ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
  1. ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
  1. ..;
  1. .;Movement diagnosis codes
  1. . I '$D(^DGPT(DA,"M")) Q
  1. . S D1=0
  1. .;Loop thru Movement diagnosis codes on zero node
  1. . F S D1=+$O(^DGPT(DA,"M",D1)) Q:D1=0 D
  1. .. S TEMPS=$G(^DGPT(DA,"M",D1,0))
  1. .. S DAS=DA_";M;"_D1_";"_0
  1. .. S DATE=$P(TEMPS,U,10)
  1. ..;If the movement date is missing use the admission date.
  1. .. I DATE="" S DATE=ADMDT
  1. .. S KND=0
  1. .. F JND=5,6,7,8,9,11,12,13,14,15 D
  1. ... S CODEP=$P(TEMPS,U,JND)
  1. ... I CODEP="" Q
  1. ... S KND=KND+1
  1. ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
  1. ... S CODE=$$CODEC^ICDEX(80,CODEP)
  1. ... I $P(CODE,U,1)=-1 D Q
  1. .... S ETEXT=DAS_" node has the invalid code "_CODE
  1. .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1. ... S CC(CODESYS)=CC(CODESYS)+1
  1. ... S NODE="M ICD"_KND
  1. ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
  1. ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
  1. .;
  1. .;Begin block of code for 501 Movement fields ICD 11 through ICD 25.
  1. . S D1=0
  1. .;Loop thru Movement diagnosis codes on 81 node
  1. . F S D1=+$O(^DGPT(DA,"M",D1)) Q:D1=0 D
  1. .. S TEMPS=$G(^DGPT(DA,"M",D1,81)) ;ICD 11 through ICD 25
  1. .. S DAS=DA_";M;"_D1_";"_81
  1. .. S DATE=$P($G(^DGPT(DA,"M",D1,0)),U,10) ;Movement Date
  1. ..;If the movement date is missing use the admission date.
  1. .. I DATE="" S DATE=ADMDT
  1. .. S KND=10
  1. .. F JND=1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 D
  1. ... S CODEP=$P(TEMPS,U,JND)
  1. ... I CODEP="" Q
  1. ... S KND=KND+1
  1. ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
  1. ... S CODE=$$CODEC^ICDEX(80,CODEP)
  1. ... I $P(CODE,U,1)=-1 D Q
  1. .... S ETEXT=DAS_" node has the invalid code "_CODE
  1. .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1. ... S CC(CODESYS)=CC(CODESYS)+1
  1. ... S NODE="M ICD"_KND
  1. ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
  1. ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
  1. .;End block of code for 501 Movement fields ICD 11 through ICD 25.
  1. .;
  1. S END=$H
  1. S CODESYS="",TOTAL=0
  1. F S CODESYS=$O(CC(CODESYS)) Q:CODESYS="" D
  1. . S TOTAL=TOTAL+CC(CODESYS)
  1. . S TEXT=CC(CODESYS)_" PTF "_CODESYS_" results indexed."
  1. . D MES^XPDUTL(TEXT)
  1. D DETIME^PXRMSXRM(START,END)
  1. ;If there were errors send a message.
  1. I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL)
  1. ;Send a MailMan message with the results.
  1. D COMMSG^PXRMSXRM(GLOBAL,START,END,TOTAL,NERROR)
  1. S ^PXRMINDX(45,"GLOBAL NAME")=GLOBAL
  1. S ^PXRMINDX(45,"BUILT BY")=DUZ
  1. S ^PXRMINDX(45,"DATE BUILT")=$$NOW^XLFDT
  1. Q
  1. ;
  1. ;=============================================
  1. KPTFDD(X,DA,NODE) ;Delete index for PTF discharge ICD diagnosis data.
  1. ;X(1)=DFN, X(2)=ADMISSION DATE, X(3)=TYPE OF RECORD,
  1. ;X(4)=ICD DIAGNOSIS, X(5)=DISCHARGE DATE
  1. ;NODE name for:
  1. ; - PRINCIPAL DIAGNOSIS is DXLS
  1. ; - PRINCIPAL DIAGNOSIS pre 1986 it is PDX
  1. ; - SECONDARY DIAGNOSIS 1 through 24 is 'D SD1' through 'D SD24'.
  1. ;
  1. ;Census records are not indexed.
  1. I X(3)=2 Q
  1. N CODE,CODESYS,DAS,DATE
  1. ;If there is no discharge date use the admission date.
  1. S DATE=$S(X(5)'="":X(5),1:X(2))
  1. ;PRINCIPAL DIAGNOSIS and SECONDARY DIAGNOSIS 1 through 9 on 70 node
  1. ;SECONDARY DIAGNOSIS 10 through 24 on 71 node
  1. S DAS=$S($E(NODE,5,6)<10:DA_";70",1:DA_";71")
  1. S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,X(4))),U,3)
  1. S CODE=$$CODEC^ICDEX(80,X(4))
  1. K ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,X(1),DATE,DAS)
  1. K ^PXRMINDX(45,CODESYS,"PNI",X(1),NODE,CODE,DATE,DAS)
  1. Q
  1. ;
  1. ;=============================================
  1. KPTFMD(X,DA,NODE) ;Delete index for PTF movement ICD diagnosis data.
  1. ;X(1)=MOVEMENT DATE, X(2)=ICD DIAGNOSIS
  1. ;NODE names for ICD1 1 through ICD 25 are 'M ICD1' through 'M ICD25'.
  1. ;
  1. ;Census records are not indexed.
  1. I $P(^DGPT(DA(1),0),U,11)=2 Q
  1. N ADMDT,CODE,CODESYS,DAS,DFN,LOCATION,MDATE,TEMP
  1. S TEMP=^DGPT(DA(1),0)
  1. S DFN=$P(TEMP,U,1)
  1. S ADMDT=$P(TEMP,U,2)
  1. ;If the Movement Date is null use the Admission Date.
  1. S MDATE=$S(X(1)="":ADMDT,1:X(1))
  1. ;ICD 1 through ICD 10 on 0 node, ICD 11 through ICD 25 on 81 node
  1. S LOCATION=$S($E(NODE,6,7)<11:0,1:"81")
  1. S DAS=DA(1)_";M;"_DA_";"_LOCATION
  1. S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,X(2))),U,3)
  1. S CODE=$$CODEC^ICDEX(80,X(2))
  1. K ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,MDATE,DAS)
  1. K ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,MDATE,DAS)
  1. Q
  1. ;
  1. ;=============================================
  1. KPTFP(X,DA,NODE,NUM) ;Delete index entry for PTF ICD surgeries & procedure data.
  1. ;For node 401 surgery node:
  1. ;X(1)=SURGERY/PROCEDURE DATE, X(2)=ICD procedure
  1. ;For node 601, procedure node:
  1. ;X(1)=PROCEDURE DATE, X(2)=ICD procedure
  1. ;NODE name is S (for 401 surgery) or P (for 601 procedure).
  1. ;NUM is either a:
  1. ; - procedure code number for PROCEDURE CODE 1 through PROCEDURE CODE 25
  1. ; or surgery code number for OPERATION CODE 1 through OPERATION CODE 25
  1. ;
  1. ;Census records are not indexed.
  1. I $P(^DGPT(DA(1),0),U,11)=2 Q
  1. N DAS,DFN,NNAME,CSI,LOCATION
  1. S DFN=$P(^DGPT(DA(1),0),U,1)
  1. S NNAME=NODE_NUM
  1. ;401 OPERATION CODE 1 through 20 on 0 node, OPERATION CODE 21 through 25 on 1 node
  1. ;601 PROCEDURE 1 through 20 on 0 node, PROCEDURE CODE 21 through 25 on 1 node
  1. S LOCATION=$S(NUM<21:0,1:1)
  1. S DAS=DA(1)_";"_NODE_";"_DA_";"_LOCATION
  1. S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80.1,X(2))),U,3)
  1. S CODE=$$CODEC^ICDEX(80.1,X(2))
  1. K ^PXRMINDX(45,CODESYS,"INP",CODE,NNAME,DFN,X(1),DAS)
  1. K ^PXRMINDX(45,CODESYS,"PNI",DFN,NNAME,CODE,X(1),DAS)
  1. Q
  1. ;
  1. ;=============================================
  1. SPTFDD(X,DA,NODE) ;Set index for PTF discharge ICD diagnoses.
  1. ;X(1)=DFN, X(2)=ADMISSION DATE, X(3)=TYPE OF RECORD,
  1. ;X(4)=ICD DIAGNOSIS, X(5)=DISCHARGE DATE
  1. ;NODE name for:
  1. ; - PRINCIPAL DIAGNOSIS is DXLS
  1. ; - PRINCIPAL DIAGNOSIS pre 1986 it is PDX
  1. ; - SECONDARY DIAGNOSIS 1 through 24 is 'D SD1' through 'D SD24'.
  1. ;
  1. ;Census records are not indexed.
  1. I X(3)=2 Q
  1. N CODE,CODESYS,DAS,DATE
  1. ;If there is no discharge date use the admission date.
  1. S DATE=$S(X(5)'="":X(5),1:X(2))
  1. ;PRINCIPAL DIAGNOSIS and SECONDARY DIAGNOSIS 1 through 9 on 70 node
  1. ;SECONDARY DIAGNOSIS 10 through 24 on 71 node
  1. S DAS=$S($E(NODE,5,6)<10:DA_";70",1:DA_";71")
  1. S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,X(4))),U,3)
  1. S CODE=$$CODEC^ICDEX(80,X(4))
  1. S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,X(1),DATE,DAS)=""
  1. S ^PXRMINDX(45,CODESYS,"PNI",X(1),NODE,CODE,DATE,DAS)=""
  1. Q
  1. ;
  1. ;=============================================
  1. SPTFMD(X,DA,NODE) ;Set index for PTF movement ICD diagnosis data.
  1. ;X(1)=MOVEMENT DATE, X(2)=ICD DIAGNOSIS
  1. ;NODE names for ICD1 1 through ICD 25 are 'M ICD1' through 'M ICD25'.
  1. ;
  1. ;Census records are not indexed.
  1. I $P(^DGPT(DA(1),0),U,11)=2 Q
  1. N ADMDT,CODE,CODESYS,DAS,DFN,LOCATION,MDATE,TEMP
  1. S TEMP=^DGPT(DA(1),0)
  1. S DFN=$P(TEMP,U,1)
  1. S ADMDT=$P(TEMP,U,2)
  1. ;If the Movement Date is null use the Admission Date.
  1. S MDATE=$S(X(1)="":ADMDT,1:X(1))
  1. ;ICD 1 through ICD 10 on 0 node, ICD 11 through ICD 25 on 81 node
  1. S LOCATION=$S($E(NODE,6,7)<11:0,1:"81")
  1. S DAS=DA(1)_";M;"_DA_";"_LOCATION
  1. S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,X(2))),U,3)
  1. S CODE=$$CODEC^ICDEX(80,X(2))
  1. S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,MDATE,DAS)=""
  1. S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,MDATE,DAS)=""
  1. Q
  1. ;
  1. ;=============================================
  1. SPTFP(X,DA,NODE,NUM) ;Set index for PTF ICD surgeries & procedures.
  1. ;For node 401 surgery node:
  1. ;X(1)=SURGERY/PROCEDURE DATE, X(2)=ICD procedure
  1. ;For node 601, procedure node:
  1. ;X(1)=PROCEDURE DATE, X(2)=ICD procedure
  1. ;NODE name is S (for 401 surgery) or P (for 601 procedure).
  1. ;NUM is either a:
  1. ; - procedure code number for PROCEDURE CODE 1 through PROCEDURE CODE 25
  1. ; or surgery code number for OPERATION CODE 1 through OPERATION CODE 25
  1. ;
  1. ;Census records are not indexed.
  1. I $P(^DGPT(DA(1),0),U,11)=2 Q
  1. N CODE,CODESYS,DAS,DFN,NNAME,LOCATION
  1. S DFN=$P(^DGPT(DA(1),0),U,1)
  1. S NNAME=NODE_NUM
  1. ;401 OPERATION CODE 1 through 20 on 0 node, OPERATION CODE 21 through 25 on 1 node
  1. ;601 PROCEDURE 1 through 20 on 0 node, PROCEDURE CODE 21 through 25 on 1 node
  1. S LOCATION=$S(NUM<21:0,1:1)
  1. S DAS=DA(1)_";"_NODE_";"_DA_";"_LOCATION
  1. S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80.1,X(2))),U,3)
  1. S CODE=$$CODEC^ICDEX(80.1,X(2))
  1. S ^PXRMINDX(45,CODESYS,"INP",CODE,NNAME,DFN,X(1),DAS)=""
  1. S ^PXRMINDX(45,CODESYS,"PNI",DFN,NNAME,CODE,X(1),DAS)=""
  1. Q