- DGPTDDCR ;SLC/PKR,ALB/KCL - Routines for setting and killing Clinical Reminders Index. ;5/11/2015
- ;;5.3;Registration;**478,862,884**;Aug 13, 1993;Build 31
- ;=============================================
- ;The structure of the Index is:
- ; ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE/TIME,DAS)
- ; ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE/TIME,DAS)
- ;where code is the actual code and not a pointer.
- ;
- ;DBIA #4114 covers setting and killing of ^PXRMINDX(45).
- ;DBIA #4521 covers use of INDEX entry point to build
- ;the Clinical Reminders Index for the PTF (#45) file.
- ;DBIA #5679 covers references to ^LEXU entry points.
- ;DBIA #5747 covers references to ^ICDEX entry points.
- ;
- ;=============================================
- INDEX ;Build all the indexes for PTF.
- N ADMDT,CC,CODE,CODEP,CODESYS,D1,DA,DAS,DATE,DFN,END,ENTRIES,ETEXT
- N GLOBAL,IND,JND,KND,NERROR,NODE,START
- N TEMP0,TEMP70,TEMP71,TEMPP,TEMPS,TENP,TEXT,TOTAL
- ;DBIA #4114
- ;Don't leave any old stuff around.
- K ^PXRMINDX(45)
- S GLOBAL=$$GET1^DID(45,"","","GLOBAL NAME")
- S ENTRIES=$P(^DGPT(0),U,4)
- S TENP=ENTRIES/10
- S TENP=+$P(TENP,".",1)
- I TENP<1 S TENP=1
- D BMES^XPDUTL("Building indexes for DGPT")
- S TEXT="There are "_ENTRIES_" entries to process."
- D MES^XPDUTL(TEXT)
- S START=$H
- ;Initialize the ICD coding system variable.
- S CODESYS=""
- ;DBIA #5679
- F S CODESYS=$$NXSAB^LEXU(CODESYS,0) Q:CODESYS="" I $P($$CSYS^LEXU(CODESYS),U,4)["ICD" S CC(CODESYS)=0
- S (DA,IND,NERROR)=0
- F S DA=+$O(^DGPT(DA)) Q:DA=0 D
- .;Make sure the 0 node is defined.
- . I '$D(^DGPT(DA,0)) D Q
- .. S ETEXT="IEN "_DA_" is missing the 0 node."
- .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- .;Save the admission date.
- . S ADMDT=$P(^DGPT(DA,0),U,2)
- . I ADMDT="" D Q
- .. S ETEXT="IEN "_DA_" is missing the Admission Date which is a required field."
- .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- . S IND=IND+1
- . I IND#TENP=0 D
- .. S TEXT="Processing entry "_IND
- .. D MES^XPDUTL(TEXT)
- . I IND#10000=0 W "."
- . S TEMP0=$G(^DGPT(DA,0))
- .;Census records are not indexed.
- . I $P(TEMP0,U,11)=2 Q
- . S DFN=$P(TEMP0,U,1)
- . I DFN="" D Q
- .. S ETEXT=DA_" no patient"
- .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- .;Check the surgery nodes.
- . S D1=0
- .;loop thru surgeries on zero node
- . F S D1=+$O(^DGPT(DA,"S",D1)) Q:D1=0 D
- .. S TEMPS=$G(^DGPT(DA,"S",D1,0))
- .. S DATE=$P(TEMPS,U,1)
- .. I DATE="" D Q
- ... S ETEXT=DA_" S node missing date"
- ... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
- .. S DAS=DA_";S;"_D1_";0"
- .. S KND=0
- .. F JND=8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27 D
- ... S KND=KND+1
- ... S CODEP=$P(TEMPS,U,JND)
- ... I CODEP="" Q
- ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80.1,CODEP)),U,3)
- ... S CODE=$$CODEC^ICDEX(80.1,CODEP)
- ... I $P(CODE,U,1)=-1 D Q
- .... S ETEXT=DAS_" has the invalid code "_CODE
- .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- ... S CC(CODESYS)=CC(CODESYS)+1
- ... S NODE="S"_KND
- ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- .;
- .;Begin block of code for 401 Operation Code 21 field through Operation Code 25 field.
- . N DGDATA,DGPIECE
- . S D1=0
- .;loop thru surgeries on one node
- . F S D1=+$O(^DGPT(DA,"S",D1)) Q:D1=0 D
- .. S TEMPS=$G(^DGPT(DA,"S",D1,1)) ;Operation Code 21-25
- .. S DGDATA=0
- .. F DGPIECE=1:1:5 I +$P(TEMPS,U,DGPIECE) S DGDATA=1
- .. Q:'$G(DGDATA) ;quit if no data on the node
- .. S DATE=+$G(^DGPT(DA,"S",D1,0)) ;Surgery/Procedure Date
- .. I DATE=0 D Q
- ... S ETEXT=DA_" S node missing date"
- ... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
- .. S DAS=DA_";S;"_D1_";1"
- .. S KND=20
- .. F JND=1,2,3,4,5 D
- ... S KND=KND+1
- ... S CODEP=$P(TEMPS,U,JND)
- ... I CODEP="" Q
- ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80.1,CODEP)),U,3)
- ... S CODE=$$CODEC^ICDEX(80.1,CODEP)
- ... I $P(CODE,U,1)=-1 D Q
- .... S ETEXT=DAS_" has the invalid code "_CODE
- .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- ... S CC(CODESYS)=CC(CODESYS)+1
- ... S NODE="S"_KND
- ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- .;End block of code for 401 Operation Code 21 field through Operation Code 25 field.
- .;
- .;Check the procedure nodes.
- . S D1=0
- .;loop thru procedures on zero node
- . F S D1=+$O(^DGPT(DA,"P",D1)) Q:D1=0 D
- .. S TEMPP=$G(^DGPT(DA,"P",D1,0))
- .. S DATE=$P(TEMPP,U,1)
- .. I DATE="" D Q
- ... S ETEXT=DA_" P node missing date"
- ... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
- .. S DAS=DA_";P;"_D1_";0"
- .. S KND=0
- .. F JND=5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24 D
- ... S KND=KND+1
- ... S CODEP=$P(TEMPP,U,JND)
- ... I CODEP="" Q
- ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80.1,CODEP)),U,3)
- ... S CODE=$$CODEC^ICDEX(80.1,CODEP)
- ... I $P(CODE,U,1)=-1 D Q
- .... S ETEXT=DAS_" has the invalid code "_CODE
- .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- ... S CC(CODESYS)=CC(CODESYS)+1
- ... S NODE="P"_KND
- ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- .;
- .;Begin block of code for 601 Procedure Code fields ICD 21 through ICD 25.
- . N DGDATA,DGPIECE
- . S D1=0
- .;loop thru procedures on one node
- . F S D1=+$O(^DGPT(DA,"P",D1)) Q:D1=0 D
- .. S TEMPP=$G(^DGPT(DA,"P",D1,1)) ;ICD 21 through ICD 25
- .. S DGDATA=0
- .. F DGPIECE=1:1:5 I +$P(TEMPP,U,DGPIECE) S DGDATA=1
- .. Q:'$G(DGDATA) ;quit if no data on the node
- .. S DATE=+$G(^DGPT(DA,"P",D1,0)) ;Procedure Date
- .. I DATE=0 D Q
- ... S ETEXT=DA_" P node missing date"
- ... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
- .. S DAS=DA_";P;"_D1_";1"
- .. S KND=20
- .. F JND=1,2,3,4,5 D
- ... S KND=KND+1
- ... S CODEP=$P(TEMPP,U,JND)
- ... I CODEP="" Q
- ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80.1,CODEP)),U,3)
- ... S CODE=$$CODEC^ICDEX(80.1,CODEP)
- ... I $P(CODE,U,1)=-1 D Q
- .... S ETEXT=DAS_" has the invalid code "_CODE
- .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- ... S CC(CODESYS)=CC(CODESYS)+1
- ... S NODE="P"_KND
- ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- .;End block of code for 601 Procedure Code fields ICD 21 through ICD 25.
- .;
- .;Discharge ICD codes
- . I $D(^DGPT(DA,70)) D
- .. S TEMP70=$G(^DGPT(DA,70))
- .. S TEMP71=$G(^DGPT(DA,71))
- .. S DATE=$P(TEMP70,U,1)
- .. I DATE="" S DATE=$P(TEMP0,U,2)
- .. S DAS=DA_";70"
- .. S CODEP=$P(TEMP70,U,10)
- .. I CODEP'="" D
- ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
- ... S CODE=$$CODEC^ICDEX(80,CODEP)
- ... I $P(CODE,U,1)=-1 D Q
- .... S ETEXT=DAS_" DXLS has the invalid code "_CODE
- .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- ... E D
- .... S CC(CODESYS)=CC(CODESYS)+1
- .... S ^PXRMINDX(45,CODESYS,"INP",CODE,"DXLS",DFN,DATE,DAS)=""
- .... S ^PXRMINDX(45,CODESYS,"PNI",DFN,"DXLS",CODE,DATE,DAS)=""
- ..;
- .. S CODEP=$P(TEMP70,U,11)
- .. I CODEP'="" D
- ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
- ... S CODE=$$CODEC^ICDEX(80,CODEP)
- ... I $P(CODE,U,1)=-1 D Q
- .... S ETEXT=DAS_" PDX has the invalid code "_CODE
- .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- ... E D
- .... S CC(CODESYS)=CC(CODESYS)+1
- .... S ^PXRMINDX(45,CODESYS,"INP",CODE,"PDX",DFN,DATE,DAS)=""
- .... S ^PXRMINDX(45,CODESYS,"PNI",DFN,"PDX",CODE,DATE,DAS)=""
- ..;
- ..;70 node secondary diagnosis
- .. S KND=0
- .. F JND=16,17,18,19,20,21,22,23,24 D
- ... S KND=KND+1
- ... S CODEP=$P(TEMP70,U,JND)
- ... I CODEP="" Q
- ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
- ... S CODE=$$CODEC^ICDEX(80,CODEP)
- ... I $P(CODE,U,1)=-1 D Q
- .... S ETEXT=DAS_" node has the invalid code "_CODE
- .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- ... S CC(CODESYS)=CC(CODESYS)+1
- ... S NODE="D SD"_KND
- ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- ..;
- ..;71 node secondary diagnosis
- .. S DAS=DA_";71"
- .. S KND=9
- .. F JND=1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 D
- ... S KND=KND+1
- ... S CODEP=$P(TEMP71,U,JND)
- ... I CODEP="" Q
- ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
- ... S CODE=$$CODEC^ICDEX(80,CODEP)
- ... I $P(CODE,U,1)=-1 D Q
- .... S ETEXT=DAS_" node has the invalid code "_CODE
- .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- ... S CC(CODESYS)=CC(CODESYS)+1
- ... S NODE="D SD"_KND
- ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- ..;
- .;Movement diagnosis codes
- . I '$D(^DGPT(DA,"M")) Q
- . S D1=0
- .;Loop thru Movement diagnosis codes on zero node
- . F S D1=+$O(^DGPT(DA,"M",D1)) Q:D1=0 D
- .. S TEMPS=$G(^DGPT(DA,"M",D1,0))
- .. S DAS=DA_";M;"_D1_";"_0
- .. S DATE=$P(TEMPS,U,10)
- ..;If the movement date is missing use the admission date.
- .. I DATE="" S DATE=ADMDT
- .. S KND=0
- .. F JND=5,6,7,8,9,11,12,13,14,15 D
- ... S CODEP=$P(TEMPS,U,JND)
- ... I CODEP="" Q
- ... S KND=KND+1
- ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
- ... S CODE=$$CODEC^ICDEX(80,CODEP)
- ... I $P(CODE,U,1)=-1 D Q
- .... S ETEXT=DAS_" node has the invalid code "_CODE
- .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- ... S CC(CODESYS)=CC(CODESYS)+1
- ... S NODE="M ICD"_KND
- ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- .;
- .;Begin block of code for 501 Movement fields ICD 11 through ICD 25.
- . S D1=0
- .;Loop thru Movement diagnosis codes on 81 node
- . F S D1=+$O(^DGPT(DA,"M",D1)) Q:D1=0 D
- .. S TEMPS=$G(^DGPT(DA,"M",D1,81)) ;ICD 11 through ICD 25
- .. S DAS=DA_";M;"_D1_";"_81
- .. S DATE=$P($G(^DGPT(DA,"M",D1,0)),U,10) ;Movement Date
- ..;If the movement date is missing use the admission date.
- .. I DATE="" S DATE=ADMDT
- .. S KND=10
- .. F JND=1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 D
- ... S CODEP=$P(TEMPS,U,JND)
- ... I CODEP="" Q
- ... S KND=KND+1
- ... S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
- ... S CODE=$$CODEC^ICDEX(80,CODEP)
- ... I $P(CODE,U,1)=-1 D Q
- .... S ETEXT=DAS_" node has the invalid code "_CODE
- .... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- ... S CC(CODESYS)=CC(CODESYS)+1
- ... S NODE="M ICD"_KND
- ... S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- ... S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- .;End block of code for 501 Movement fields ICD 11 through ICD 25.
- .;
- S END=$H
- S CODESYS="",TOTAL=0
- F S CODESYS=$O(CC(CODESYS)) Q:CODESYS="" D
- . S TOTAL=TOTAL+CC(CODESYS)
- . S TEXT=CC(CODESYS)_" PTF "_CODESYS_" results indexed."
- . D MES^XPDUTL(TEXT)
- D DETIME^PXRMSXRM(START,END)
- ;If there were errors send a message.
- I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL)
- ;Send a MailMan message with the results.
- D COMMSG^PXRMSXRM(GLOBAL,START,END,TOTAL,NERROR)
- S ^PXRMINDX(45,"GLOBAL NAME")=GLOBAL
- S ^PXRMINDX(45,"BUILT BY")=DUZ
- S ^PXRMINDX(45,"DATE BUILT")=$$NOW^XLFDT
- Q
- ;
- ;=============================================
- KPTFDD(X,DA,NODE) ;Delete index for PTF discharge ICD diagnosis data.
- ;X(1)=DFN, X(2)=ADMISSION DATE, X(3)=TYPE OF RECORD,
- ;X(4)=ICD DIAGNOSIS, X(5)=DISCHARGE DATE
- ;NODE name for:
- ; - PRINCIPAL DIAGNOSIS is DXLS
- ; - PRINCIPAL DIAGNOSIS pre 1986 it is PDX
- ; - SECONDARY DIAGNOSIS 1 through 24 is 'D SD1' through 'D SD24'.
- ;
- ;Census records are not indexed.
- I X(3)=2 Q
- N CODE,CODESYS,DAS,DATE
- ;If there is no discharge date use the admission date.
- S DATE=$S(X(5)'="":X(5),1:X(2))
- ;PRINCIPAL DIAGNOSIS and SECONDARY DIAGNOSIS 1 through 9 on 70 node
- ;SECONDARY DIAGNOSIS 10 through 24 on 71 node
- S DAS=$S($E(NODE,5,6)<10:DA_";70",1:DA_";71")
- S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,X(4))),U,3)
- S CODE=$$CODEC^ICDEX(80,X(4))
- K ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,X(1),DATE,DAS)
- K ^PXRMINDX(45,CODESYS,"PNI",X(1),NODE,CODE,DATE,DAS)
- Q
- ;
- ;=============================================
- KPTFMD(X,DA,NODE) ;Delete index for PTF movement ICD diagnosis data.
- ;X(1)=MOVEMENT DATE, X(2)=ICD DIAGNOSIS
- ;NODE names for ICD1 1 through ICD 25 are 'M ICD1' through 'M ICD25'.
- ;
- ;Census records are not indexed.
- I $P(^DGPT(DA(1),0),U,11)=2 Q
- N ADMDT,CODE,CODESYS,DAS,DFN,LOCATION,MDATE,TEMP
- S TEMP=^DGPT(DA(1),0)
- S DFN=$P(TEMP,U,1)
- S ADMDT=$P(TEMP,U,2)
- ;If the Movement Date is null use the Admission Date.
- S MDATE=$S(X(1)="":ADMDT,1:X(1))
- ;ICD 1 through ICD 10 on 0 node, ICD 11 through ICD 25 on 81 node
- S LOCATION=$S($E(NODE,6,7)<11:0,1:"81")
- S DAS=DA(1)_";M;"_DA_";"_LOCATION
- S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,X(2))),U,3)
- S CODE=$$CODEC^ICDEX(80,X(2))
- K ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,MDATE,DAS)
- K ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,MDATE,DAS)
- Q
- ;
- ;=============================================
- KPTFP(X,DA,NODE,NUM) ;Delete index entry for PTF ICD surgeries & procedure data.
- ;For node 401 surgery node:
- ;X(1)=SURGERY/PROCEDURE DATE, X(2)=ICD procedure
- ;For node 601, procedure node:
- ;X(1)=PROCEDURE DATE, X(2)=ICD procedure
- ;NODE name is S (for 401 surgery) or P (for 601 procedure).
- ;NUM is either a:
- ; - procedure code number for PROCEDURE CODE 1 through PROCEDURE CODE 25
- ; or surgery code number for OPERATION CODE 1 through OPERATION CODE 25
- ;
- ;Census records are not indexed.
- I $P(^DGPT(DA(1),0),U,11)=2 Q
- N DAS,DFN,NNAME,CSI,LOCATION
- S DFN=$P(^DGPT(DA(1),0),U,1)
- S NNAME=NODE_NUM
- ;401 OPERATION CODE 1 through 20 on 0 node, OPERATION CODE 21 through 25 on 1 node
- ;601 PROCEDURE 1 through 20 on 0 node, PROCEDURE CODE 21 through 25 on 1 node
- S LOCATION=$S(NUM<21:0,1:1)
- S DAS=DA(1)_";"_NODE_";"_DA_";"_LOCATION
- S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80.1,X(2))),U,3)
- S CODE=$$CODEC^ICDEX(80.1,X(2))
- K ^PXRMINDX(45,CODESYS,"INP",CODE,NNAME,DFN,X(1),DAS)
- K ^PXRMINDX(45,CODESYS,"PNI",DFN,NNAME,CODE,X(1),DAS)
- Q
- ;
- ;=============================================
- SPTFDD(X,DA,NODE) ;Set index for PTF discharge ICD diagnoses.
- ;X(1)=DFN, X(2)=ADMISSION DATE, X(3)=TYPE OF RECORD,
- ;X(4)=ICD DIAGNOSIS, X(5)=DISCHARGE DATE
- ;NODE name for:
- ; - PRINCIPAL DIAGNOSIS is DXLS
- ; - PRINCIPAL DIAGNOSIS pre 1986 it is PDX
- ; - SECONDARY DIAGNOSIS 1 through 24 is 'D SD1' through 'D SD24'.
- ;
- ;Census records are not indexed.
- I X(3)=2 Q
- N CODE,CODESYS,DAS,DATE
- ;If there is no discharge date use the admission date.
- S DATE=$S(X(5)'="":X(5),1:X(2))
- ;PRINCIPAL DIAGNOSIS and SECONDARY DIAGNOSIS 1 through 9 on 70 node
- ;SECONDARY DIAGNOSIS 10 through 24 on 71 node
- S DAS=$S($E(NODE,5,6)<10:DA_";70",1:DA_";71")
- S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,X(4))),U,3)
- S CODE=$$CODEC^ICDEX(80,X(4))
- S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,X(1),DATE,DAS)=""
- S ^PXRMINDX(45,CODESYS,"PNI",X(1),NODE,CODE,DATE,DAS)=""
- Q
- ;
- ;=============================================
- SPTFMD(X,DA,NODE) ;Set index for PTF movement ICD diagnosis data.
- ;X(1)=MOVEMENT DATE, X(2)=ICD DIAGNOSIS
- ;NODE names for ICD1 1 through ICD 25 are 'M ICD1' through 'M ICD25'.
- ;
- ;Census records are not indexed.
- I $P(^DGPT(DA(1),0),U,11)=2 Q
- N ADMDT,CODE,CODESYS,DAS,DFN,LOCATION,MDATE,TEMP
- S TEMP=^DGPT(DA(1),0)
- S DFN=$P(TEMP,U,1)
- S ADMDT=$P(TEMP,U,2)
- ;If the Movement Date is null use the Admission Date.
- S MDATE=$S(X(1)="":ADMDT,1:X(1))
- ;ICD 1 through ICD 10 on 0 node, ICD 11 through ICD 25 on 81 node
- S LOCATION=$S($E(NODE,6,7)<11:0,1:"81")
- S DAS=DA(1)_";M;"_DA_";"_LOCATION
- S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,X(2))),U,3)
- S CODE=$$CODEC^ICDEX(80,X(2))
- S ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,MDATE,DAS)=""
- S ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,MDATE,DAS)=""
- Q
- ;
- ;=============================================
- SPTFP(X,DA,NODE,NUM) ;Set index for PTF ICD surgeries & procedures.
- ;For node 401 surgery node:
- ;X(1)=SURGERY/PROCEDURE DATE, X(2)=ICD procedure
- ;For node 601, procedure node:
- ;X(1)=PROCEDURE DATE, X(2)=ICD procedure
- ;NODE name is S (for 401 surgery) or P (for 601 procedure).
- ;NUM is either a:
- ; - procedure code number for PROCEDURE CODE 1 through PROCEDURE CODE 25
- ; or surgery code number for OPERATION CODE 1 through OPERATION CODE 25
- ;
- ;Census records are not indexed.
- I $P(^DGPT(DA(1),0),U,11)=2 Q
- N CODE,CODESYS,DAS,DFN,NNAME,LOCATION
- S DFN=$P(^DGPT(DA(1),0),U,1)
- S NNAME=NODE_NUM
- ;401 OPERATION CODE 1 through 20 on 0 node, OPERATION CODE 21 through 25 on 1 node
- ;601 PROCEDURE 1 through 20 on 0 node, PROCEDURE CODE 21 through 25 on 1 node
- S LOCATION=$S(NUM<21:0,1:1)
- S DAS=DA(1)_";"_NODE_";"_DA_";"_LOCATION
- S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80.1,X(2))),U,3)
- S CODE=$$CODEC^ICDEX(80.1,X(2))
- S ^PXRMINDX(45,CODESYS,"INP",CODE,NNAME,DFN,X(1),DAS)=""
- S ^PXRMINDX(45,CODESYS,"PNI",DFN,NNAME,CODE,X(1),DAS)=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTDDCR 16889 printed Feb 19, 2025@00:17:58 Page 2
- 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
- +2 ;=============================================
- +3 ;The structure of the Index is:
- +4 ; ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE/TIME,DAS)
- +5 ; ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE/TIME,DAS)
- +6 ;where code is the actual code and not a pointer.
- +7 ;
- +8 ;DBIA #4114 covers setting and killing of ^PXRMINDX(45).
- +9 ;DBIA #4521 covers use of INDEX entry point to build
- +10 ;the Clinical Reminders Index for the PTF (#45) file.
- +11 ;DBIA #5679 covers references to ^LEXU entry points.
- +12 ;DBIA #5747 covers references to ^ICDEX entry points.
- +13 ;
- +14 ;=============================================
- INDEX ;Build all the indexes for PTF.
- +1 NEW ADMDT,CC,CODE,CODEP,CODESYS,D1,DA,DAS,DATE,DFN,END,ENTRIES,ETEXT
- +2 NEW GLOBAL,IND,JND,KND,NERROR,NODE,START
- +3 NEW TEMP0,TEMP70,TEMP71,TEMPP,TEMPS,TENP,TEXT,TOTAL
- +4 ;DBIA #4114
- +5 ;Don't leave any old stuff around.
- +6 KILL ^PXRMINDX(45)
- +7 SET GLOBAL=$$GET1^DID(45,"","","GLOBAL NAME")
- +8 SET ENTRIES=$PIECE(^DGPT(0),U,4)
- +9 SET TENP=ENTRIES/10
- +10 SET TENP=+$PIECE(TENP,".",1)
- +11 IF TENP<1
- SET TENP=1
- +12 DO BMES^XPDUTL("Building indexes for DGPT")
- +13 SET TEXT="There are "_ENTRIES_" entries to process."
- +14 DO MES^XPDUTL(TEXT)
- +15 SET START=$HOROLOG
- +16 ;Initialize the ICD coding system variable.
- +17 SET CODESYS=""
- +18 ;DBIA #5679
- +19 FOR
- SET CODESYS=$$NXSAB^LEXU(CODESYS,0)
- if CODESYS=""
- QUIT
- IF $PIECE($$CSYS^LEXU(CODESYS),U,4)["ICD"
- SET CC(CODESYS)=0
- +20 SET (DA,IND,NERROR)=0
- +21 FOR
- SET DA=+$ORDER(^DGPT(DA))
- if DA=0
- QUIT
- Begin DoDot:1
- +22 ;Make sure the 0 node is defined.
- +23 IF '$DATA(^DGPT(DA,0))
- Begin DoDot:2
- +24 SET ETEXT="IEN "_DA_" is missing the 0 node."
- +25 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- End DoDot:2
- QUIT
- +26 ;Save the admission date.
- +27 SET ADMDT=$PIECE(^DGPT(DA,0),U,2)
- +28 IF ADMDT=""
- Begin DoDot:2
- +29 SET ETEXT="IEN "_DA_" is missing the Admission Date which is a required field."
- +30 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- End DoDot:2
- QUIT
- +31 SET IND=IND+1
- +32 IF IND#TENP=0
- Begin DoDot:2
- +33 SET TEXT="Processing entry "_IND
- +34 DO MES^XPDUTL(TEXT)
- End DoDot:2
- +35 IF IND#10000=0
- WRITE "."
- +36 SET TEMP0=$GET(^DGPT(DA,0))
- +37 ;Census records are not indexed.
- +38 IF $PIECE(TEMP0,U,11)=2
- QUIT
- +39 SET DFN=$PIECE(TEMP0,U,1)
- +40 IF DFN=""
- Begin DoDot:2
- +41 SET ETEXT=DA_" no patient"
- +42 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- End DoDot:2
- QUIT
- +43 ;Check the surgery nodes.
- +44 SET D1=0
- +45 ;loop thru surgeries on zero node
- +46 FOR
- SET D1=+$ORDER(^DGPT(DA,"S",D1))
- if D1=0
- QUIT
- Begin DoDot:2
- +47 SET TEMPS=$GET(^DGPT(DA,"S",D1,0))
- +48 SET DATE=$PIECE(TEMPS,U,1)
- +49 IF DATE=""
- Begin DoDot:3
- +50 SET ETEXT=DA_" S node missing date"
- +51 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- QUIT
- End DoDot:3
- QUIT
- +52 SET DAS=DA_";S;"_D1_";0"
- +53 SET KND=0
- +54 FOR JND=8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27
- Begin DoDot:3
- +55 SET KND=KND+1
- +56 SET CODEP=$PIECE(TEMPS,U,JND)
- +57 IF CODEP=""
- QUIT
- +58 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80.1,CODEP)),U,3)
- +59 SET CODE=$$CODEC^ICDEX(80.1,CODEP)
- +60 IF $PIECE(CODE,U,1)=-1
- Begin DoDot:4
- +61 SET ETEXT=DAS_" has the invalid code "_CODE
- +62 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- End DoDot:4
- QUIT
- +63 SET CC(CODESYS)=CC(CODESYS)+1
- +64 SET NODE="S"_KND
- +65 SET ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- +66 SET ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- End DoDot:3
- End DoDot:2
- +67 ;
- +68 ;Begin block of code for 401 Operation Code 21 field through Operation Code 25 field.
- +69 NEW DGDATA,DGPIECE
- +70 SET D1=0
- +71 ;loop thru surgeries on one node
- +72 FOR
- SET D1=+$ORDER(^DGPT(DA,"S",D1))
- if D1=0
- QUIT
- Begin DoDot:2
- +73 ;Operation Code 21-25
- SET TEMPS=$GET(^DGPT(DA,"S",D1,1))
- +74 SET DGDATA=0
- +75 FOR DGPIECE=1:1:5
- IF +$PIECE(TEMPS,U,DGPIECE)
- SET DGDATA=1
- +76 ;quit if no data on the node
- if '$GET(DGDATA)
- QUIT
- +77 ;Surgery/Procedure Date
- SET DATE=+$GET(^DGPT(DA,"S",D1,0))
- +78 IF DATE=0
- Begin DoDot:3
- +79 SET ETEXT=DA_" S node missing date"
- +80 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- QUIT
- End DoDot:3
- QUIT
- +81 SET DAS=DA_";S;"_D1_";1"
- +82 SET KND=20
- +83 FOR JND=1,2,3,4,5
- Begin DoDot:3
- +84 SET KND=KND+1
- +85 SET CODEP=$PIECE(TEMPS,U,JND)
- +86 IF CODEP=""
- QUIT
- +87 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80.1,CODEP)),U,3)
- +88 SET CODE=$$CODEC^ICDEX(80.1,CODEP)
- +89 IF $PIECE(CODE,U,1)=-1
- Begin DoDot:4
- +90 SET ETEXT=DAS_" has the invalid code "_CODE
- +91 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- End DoDot:4
- QUIT
- +92 SET CC(CODESYS)=CC(CODESYS)+1
- +93 SET NODE="S"_KND
- +94 SET ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- +95 SET ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- End DoDot:3
- End DoDot:2
- +96 ;End block of code for 401 Operation Code 21 field through Operation Code 25 field.
- +97 ;
- +98 ;Check the procedure nodes.
- +99 SET D1=0
- +100 ;loop thru procedures on zero node
- +101 FOR
- SET D1=+$ORDER(^DGPT(DA,"P",D1))
- if D1=0
- QUIT
- Begin DoDot:2
- +102 SET TEMPP=$GET(^DGPT(DA,"P",D1,0))
- +103 SET DATE=$PIECE(TEMPP,U,1)
- +104 IF DATE=""
- Begin DoDot:3
- +105 SET ETEXT=DA_" P node missing date"
- +106 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- QUIT
- End DoDot:3
- QUIT
- +107 SET DAS=DA_";P;"_D1_";0"
- +108 SET KND=0
- +109 FOR JND=5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24
- Begin DoDot:3
- +110 SET KND=KND+1
- +111 SET CODEP=$PIECE(TEMPP,U,JND)
- +112 IF CODEP=""
- QUIT
- +113 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80.1,CODEP)),U,3)
- +114 SET CODE=$$CODEC^ICDEX(80.1,CODEP)
- +115 IF $PIECE(CODE,U,1)=-1
- Begin DoDot:4
- +116 SET ETEXT=DAS_" has the invalid code "_CODE
- +117 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- End DoDot:4
- QUIT
- +118 SET CC(CODESYS)=CC(CODESYS)+1
- +119 SET NODE="P"_KND
- +120 SET ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- +121 SET ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- End DoDot:3
- End DoDot:2
- +122 ;
- +123 ;Begin block of code for 601 Procedure Code fields ICD 21 through ICD 25.
- +124 NEW DGDATA,DGPIECE
- +125 SET D1=0
- +126 ;loop thru procedures on one node
- +127 FOR
- SET D1=+$ORDER(^DGPT(DA,"P",D1))
- if D1=0
- QUIT
- Begin DoDot:2
- +128 ;ICD 21 through ICD 25
- SET TEMPP=$GET(^DGPT(DA,"P",D1,1))
- +129 SET DGDATA=0
- +130 FOR DGPIECE=1:1:5
- IF +$PIECE(TEMPP,U,DGPIECE)
- SET DGDATA=1
- +131 ;quit if no data on the node
- if '$GET(DGDATA)
- QUIT
- +132 ;Procedure Date
- SET DATE=+$GET(^DGPT(DA,"P",D1,0))
- +133 IF DATE=0
- Begin DoDot:3
- +134 SET ETEXT=DA_" P node missing date"
- +135 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- QUIT
- End DoDot:3
- QUIT
- +136 SET DAS=DA_";P;"_D1_";1"
- +137 SET KND=20
- +138 FOR JND=1,2,3,4,5
- Begin DoDot:3
- +139 SET KND=KND+1
- +140 SET CODEP=$PIECE(TEMPP,U,JND)
- +141 IF CODEP=""
- QUIT
- +142 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80.1,CODEP)),U,3)
- +143 SET CODE=$$CODEC^ICDEX(80.1,CODEP)
- +144 IF $PIECE(CODE,U,1)=-1
- Begin DoDot:4
- +145 SET ETEXT=DAS_" has the invalid code "_CODE
- +146 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- End DoDot:4
- QUIT
- +147 SET CC(CODESYS)=CC(CODESYS)+1
- +148 SET NODE="P"_KND
- +149 SET ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- +150 SET ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- End DoDot:3
- End DoDot:2
- +151 ;End block of code for 601 Procedure Code fields ICD 21 through ICD 25.
- +152 ;
- +153 ;Discharge ICD codes
- +154 IF $DATA(^DGPT(DA,70))
- Begin DoDot:2
- +155 SET TEMP70=$GET(^DGPT(DA,70))
- +156 SET TEMP71=$GET(^DGPT(DA,71))
- +157 SET DATE=$PIECE(TEMP70,U,1)
- +158 IF DATE=""
- SET DATE=$PIECE(TEMP0,U,2)
- +159 SET DAS=DA_";70"
- +160 SET CODEP=$PIECE(TEMP70,U,10)
- +161 IF CODEP'=""
- Begin DoDot:3
- +162 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
- +163 SET CODE=$$CODEC^ICDEX(80,CODEP)
- +164 IF $PIECE(CODE,U,1)=-1
- Begin DoDot:4
- +165 SET ETEXT=DAS_" DXLS has the invalid code "_CODE
- +166 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- End DoDot:4
- QUIT
- +167 IF '$TEST
- Begin DoDot:4
- +168 SET CC(CODESYS)=CC(CODESYS)+1
- +169 SET ^PXRMINDX(45,CODESYS,"INP",CODE,"DXLS",DFN,DATE,DAS)=""
- +170 SET ^PXRMINDX(45,CODESYS,"PNI",DFN,"DXLS",CODE,DATE,DAS)=""
- End DoDot:4
- End DoDot:3
- +171 ;
- +172 SET CODEP=$PIECE(TEMP70,U,11)
- +173 IF CODEP'=""
- Begin DoDot:3
- +174 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
- +175 SET CODE=$$CODEC^ICDEX(80,CODEP)
- +176 IF $PIECE(CODE,U,1)=-1
- Begin DoDot:4
- +177 SET ETEXT=DAS_" PDX has the invalid code "_CODE
- +178 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- End DoDot:4
- QUIT
- +179 IF '$TEST
- Begin DoDot:4
- +180 SET CC(CODESYS)=CC(CODESYS)+1
- +181 SET ^PXRMINDX(45,CODESYS,"INP",CODE,"PDX",DFN,DATE,DAS)=""
- +182 SET ^PXRMINDX(45,CODESYS,"PNI",DFN,"PDX",CODE,DATE,DAS)=""
- End DoDot:4
- End DoDot:3
- +183 ;
- +184 ;70 node secondary diagnosis
- +185 SET KND=0
- +186 FOR JND=16,17,18,19,20,21,22,23,24
- Begin DoDot:3
- +187 SET KND=KND+1
- +188 SET CODEP=$PIECE(TEMP70,U,JND)
- +189 IF CODEP=""
- QUIT
- +190 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
- +191 SET CODE=$$CODEC^ICDEX(80,CODEP)
- +192 IF $PIECE(CODE,U,1)=-1
- Begin DoDot:4
- +193 SET ETEXT=DAS_" node has the invalid code "_CODE
- +194 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- End DoDot:4
- QUIT
- +195 SET CC(CODESYS)=CC(CODESYS)+1
- +196 SET NODE="D SD"_KND
- +197 SET ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- +198 SET ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- End DoDot:3
- +199 ;
- +200 ;71 node secondary diagnosis
- +201 SET DAS=DA_";71"
- +202 SET KND=9
- +203 FOR JND=1,2,3,4,5,6,7,8,9,10,11,12,13,14,15
- Begin DoDot:3
- +204 SET KND=KND+1
- +205 SET CODEP=$PIECE(TEMP71,U,JND)
- +206 IF CODEP=""
- QUIT
- +207 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
- +208 SET CODE=$$CODEC^ICDEX(80,CODEP)
- +209 IF $PIECE(CODE,U,1)=-1
- Begin DoDot:4
- +210 SET ETEXT=DAS_" node has the invalid code "_CODE
- +211 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- End DoDot:4
- QUIT
- +212 SET CC(CODESYS)=CC(CODESYS)+1
- +213 SET NODE="D SD"_KND
- +214 SET ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- +215 SET ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- End DoDot:3
- +216 ;
- End DoDot:2
- +217 ;Movement diagnosis codes
- +218 IF '$DATA(^DGPT(DA,"M"))
- QUIT
- +219 SET D1=0
- +220 ;Loop thru Movement diagnosis codes on zero node
- +221 FOR
- SET D1=+$ORDER(^DGPT(DA,"M",D1))
- if D1=0
- QUIT
- Begin DoDot:2
- +222 SET TEMPS=$GET(^DGPT(DA,"M",D1,0))
- +223 SET DAS=DA_";M;"_D1_";"_0
- +224 SET DATE=$PIECE(TEMPS,U,10)
- +225 ;If the movement date is missing use the admission date.
- +226 IF DATE=""
- SET DATE=ADMDT
- +227 SET KND=0
- +228 FOR JND=5,6,7,8,9,11,12,13,14,15
- Begin DoDot:3
- +229 SET CODEP=$PIECE(TEMPS,U,JND)
- +230 IF CODEP=""
- QUIT
- +231 SET KND=KND+1
- +232 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
- +233 SET CODE=$$CODEC^ICDEX(80,CODEP)
- +234 IF $PIECE(CODE,U,1)=-1
- Begin DoDot:4
- +235 SET ETEXT=DAS_" node has the invalid code "_CODE
- +236 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- End DoDot:4
- QUIT
- +237 SET CC(CODESYS)=CC(CODESYS)+1
- +238 SET NODE="M ICD"_KND
- +239 SET ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- +240 SET ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- End DoDot:3
- End DoDot:2
- +241 ;
- +242 ;Begin block of code for 501 Movement fields ICD 11 through ICD 25.
- +243 SET D1=0
- +244 ;Loop thru Movement diagnosis codes on 81 node
- +245 FOR
- SET D1=+$ORDER(^DGPT(DA,"M",D1))
- if D1=0
- QUIT
- Begin DoDot:2
- +246 ;ICD 11 through ICD 25
- SET TEMPS=$GET(^DGPT(DA,"M",D1,81))
- +247 SET DAS=DA_";M;"_D1_";"_81
- +248 ;Movement Date
- SET DATE=$PIECE($GET(^DGPT(DA,"M",D1,0)),U,10)
- +249 ;If the movement date is missing use the admission date.
- +250 IF DATE=""
- SET DATE=ADMDT
- +251 SET KND=10
- +252 FOR JND=1,2,3,4,5,6,7,8,9,10,11,12,13,14,15
- Begin DoDot:3
- +253 SET CODEP=$PIECE(TEMPS,U,JND)
- +254 IF CODEP=""
- QUIT
- +255 SET KND=KND+1
- +256 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
- +257 SET CODE=$$CODEC^ICDEX(80,CODEP)
- +258 IF $PIECE(CODE,U,1)=-1
- Begin DoDot:4
- +259 SET ETEXT=DAS_" node has the invalid code "_CODE
- +260 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
- End DoDot:4
- QUIT
- +261 SET CC(CODESYS)=CC(CODESYS)+1
- +262 SET NODE="M ICD"_KND
- +263 SET ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,DATE,DAS)=""
- +264 SET ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,DATE,DAS)=""
- End DoDot:3
- End DoDot:2
- +265 ;End block of code for 501 Movement fields ICD 11 through ICD 25.
- +266 ;
- End DoDot:1
- +267 SET END=$HOROLOG
- +268 SET CODESYS=""
- SET TOTAL=0
- +269 FOR
- SET CODESYS=$ORDER(CC(CODESYS))
- if CODESYS=""
- QUIT
- Begin DoDot:1
- +270 SET TOTAL=TOTAL+CC(CODESYS)
- +271 SET TEXT=CC(CODESYS)_" PTF "_CODESYS_" results indexed."
- +272 DO MES^XPDUTL(TEXT)
- End DoDot:1
- +273 DO DETIME^PXRMSXRM(START,END)
- +274 ;If there were errors send a message.
- +275 IF NERROR>0
- DO ERRMSG^PXRMSXRM(NERROR,GLOBAL)
- +276 ;Send a MailMan message with the results.
- +277 DO COMMSG^PXRMSXRM(GLOBAL,START,END,TOTAL,NERROR)
- +278 SET ^PXRMINDX(45,"GLOBAL NAME")=GLOBAL
- +279 SET ^PXRMINDX(45,"BUILT BY")=DUZ
- +280 SET ^PXRMINDX(45,"DATE BUILT")=$$NOW^XLFDT
- +281 QUIT
- +282 ;
- +283 ;=============================================
- 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,
- +2 ;X(4)=ICD DIAGNOSIS, X(5)=DISCHARGE DATE
- +3 ;NODE name for:
- +4 ; - PRINCIPAL DIAGNOSIS is DXLS
- +5 ; - PRINCIPAL DIAGNOSIS pre 1986 it is PDX
- +6 ; - SECONDARY DIAGNOSIS 1 through 24 is 'D SD1' through 'D SD24'.
- +7 ;
- +8 ;Census records are not indexed.
- +9 IF X(3)=2
- QUIT
- +10 NEW CODE,CODESYS,DAS,DATE
- +11 ;If there is no discharge date use the admission date.
- +12 SET DATE=$SELECT(X(5)'="":X(5),1:X(2))
- +13 ;PRINCIPAL DIAGNOSIS and SECONDARY DIAGNOSIS 1 through 9 on 70 node
- +14 ;SECONDARY DIAGNOSIS 10 through 24 on 71 node
- +15 SET DAS=$SELECT($EXTRACT(NODE,5,6)<10:DA_";70",1:DA_";71")
- +16 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80,X(4))),U,3)
- +17 SET CODE=$$CODEC^ICDEX(80,X(4))
- +18 KILL ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,X(1),DATE,DAS)
- +19 KILL ^PXRMINDX(45,CODESYS,"PNI",X(1),NODE,CODE,DATE,DAS)
- +20 QUIT
- +21 ;
- +22 ;=============================================
- KPTFMD(X,DA,NODE) ;Delete index for PTF movement ICD diagnosis data.
- +1 ;X(1)=MOVEMENT DATE, X(2)=ICD DIAGNOSIS
- +2 ;NODE names for ICD1 1 through ICD 25 are 'M ICD1' through 'M ICD25'.
- +3 ;
- +4 ;Census records are not indexed.
- +5 IF $PIECE(^DGPT(DA(1),0),U,11)=2
- QUIT
- +6 NEW ADMDT,CODE,CODESYS,DAS,DFN,LOCATION,MDATE,TEMP
- +7 SET TEMP=^DGPT(DA(1),0)
- +8 SET DFN=$PIECE(TEMP,U,1)
- +9 SET ADMDT=$PIECE(TEMP,U,2)
- +10 ;If the Movement Date is null use the Admission Date.
- +11 SET MDATE=$SELECT(X(1)="":ADMDT,1:X(1))
- +12 ;ICD 1 through ICD 10 on 0 node, ICD 11 through ICD 25 on 81 node
- +13 SET LOCATION=$SELECT($EXTRACT(NODE,6,7)<11:0,1:"81")
- +14 SET DAS=DA(1)_";M;"_DA_";"_LOCATION
- +15 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80,X(2))),U,3)
- +16 SET CODE=$$CODEC^ICDEX(80,X(2))
- +17 KILL ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,MDATE,DAS)
- +18 KILL ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,MDATE,DAS)
- +19 QUIT
- +20 ;
- +21 ;=============================================
- KPTFP(X,DA,NODE,NUM) ;Delete index entry for PTF ICD surgeries & procedure data.
- +1 ;For node 401 surgery node:
- +2 ;X(1)=SURGERY/PROCEDURE DATE, X(2)=ICD procedure
- +3 ;For node 601, procedure node:
- +4 ;X(1)=PROCEDURE DATE, X(2)=ICD procedure
- +5 ;NODE name is S (for 401 surgery) or P (for 601 procedure).
- +6 ;NUM is either a:
- +7 ; - procedure code number for PROCEDURE CODE 1 through PROCEDURE CODE 25
- +8 ; or surgery code number for OPERATION CODE 1 through OPERATION CODE 25
- +9 ;
- +10 ;Census records are not indexed.
- +11 IF $PIECE(^DGPT(DA(1),0),U,11)=2
- QUIT
- +12 NEW DAS,DFN,NNAME,CSI,LOCATION
- +13 SET DFN=$PIECE(^DGPT(DA(1),0),U,1)
- +14 SET NNAME=NODE_NUM
- +15 ;401 OPERATION CODE 1 through 20 on 0 node, OPERATION CODE 21 through 25 on 1 node
- +16 ;601 PROCEDURE 1 through 20 on 0 node, PROCEDURE CODE 21 through 25 on 1 node
- +17 SET LOCATION=$SELECT(NUM<21:0,1:1)
- +18 SET DAS=DA(1)_";"_NODE_";"_DA_";"_LOCATION
- +19 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80.1,X(2))),U,3)
- +20 SET CODE=$$CODEC^ICDEX(80.1,X(2))
- +21 KILL ^PXRMINDX(45,CODESYS,"INP",CODE,NNAME,DFN,X(1),DAS)
- +22 KILL ^PXRMINDX(45,CODESYS,"PNI",DFN,NNAME,CODE,X(1),DAS)
- +23 QUIT
- +24 ;
- +25 ;=============================================
- SPTFDD(X,DA,NODE) ;Set index for PTF discharge ICD diagnoses.
- +1 ;X(1)=DFN, X(2)=ADMISSION DATE, X(3)=TYPE OF RECORD,
- +2 ;X(4)=ICD DIAGNOSIS, X(5)=DISCHARGE DATE
- +3 ;NODE name for:
- +4 ; - PRINCIPAL DIAGNOSIS is DXLS
- +5 ; - PRINCIPAL DIAGNOSIS pre 1986 it is PDX
- +6 ; - SECONDARY DIAGNOSIS 1 through 24 is 'D SD1' through 'D SD24'.
- +7 ;
- +8 ;Census records are not indexed.
- +9 IF X(3)=2
- QUIT
- +10 NEW CODE,CODESYS,DAS,DATE
- +11 ;If there is no discharge date use the admission date.
- +12 SET DATE=$SELECT(X(5)'="":X(5),1:X(2))
- +13 ;PRINCIPAL DIAGNOSIS and SECONDARY DIAGNOSIS 1 through 9 on 70 node
- +14 ;SECONDARY DIAGNOSIS 10 through 24 on 71 node
- +15 SET DAS=$SELECT($EXTRACT(NODE,5,6)<10:DA_";70",1:DA_";71")
- +16 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80,X(4))),U,3)
- +17 SET CODE=$$CODEC^ICDEX(80,X(4))
- +18 SET ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,X(1),DATE,DAS)=""
- +19 SET ^PXRMINDX(45,CODESYS,"PNI",X(1),NODE,CODE,DATE,DAS)=""
- +20 QUIT
- +21 ;
- +22 ;=============================================
- SPTFMD(X,DA,NODE) ;Set index for PTF movement ICD diagnosis data.
- +1 ;X(1)=MOVEMENT DATE, X(2)=ICD DIAGNOSIS
- +2 ;NODE names for ICD1 1 through ICD 25 are 'M ICD1' through 'M ICD25'.
- +3 ;
- +4 ;Census records are not indexed.
- +5 IF $PIECE(^DGPT(DA(1),0),U,11)=2
- QUIT
- +6 NEW ADMDT,CODE,CODESYS,DAS,DFN,LOCATION,MDATE,TEMP
- +7 SET TEMP=^DGPT(DA(1),0)
- +8 SET DFN=$PIECE(TEMP,U,1)
- +9 SET ADMDT=$PIECE(TEMP,U,2)
- +10 ;If the Movement Date is null use the Admission Date.
- +11 SET MDATE=$SELECT(X(1)="":ADMDT,1:X(1))
- +12 ;ICD 1 through ICD 10 on 0 node, ICD 11 through ICD 25 on 81 node
- +13 SET LOCATION=$SELECT($EXTRACT(NODE,6,7)<11:0,1:"81")
- +14 SET DAS=DA(1)_";M;"_DA_";"_LOCATION
- +15 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80,X(2))),U,3)
- +16 SET CODE=$$CODEC^ICDEX(80,X(2))
- +17 SET ^PXRMINDX(45,CODESYS,"PNI",DFN,NODE,CODE,MDATE,DAS)=""
- +18 SET ^PXRMINDX(45,CODESYS,"INP",CODE,NODE,DFN,MDATE,DAS)=""
- +19 QUIT
- +20 ;
- +21 ;=============================================
- SPTFP(X,DA,NODE,NUM) ;Set index for PTF ICD surgeries & procedures.
- +1 ;For node 401 surgery node:
- +2 ;X(1)=SURGERY/PROCEDURE DATE, X(2)=ICD procedure
- +3 ;For node 601, procedure node:
- +4 ;X(1)=PROCEDURE DATE, X(2)=ICD procedure
- +5 ;NODE name is S (for 401 surgery) or P (for 601 procedure).
- +6 ;NUM is either a:
- +7 ; - procedure code number for PROCEDURE CODE 1 through PROCEDURE CODE 25
- +8 ; or surgery code number for OPERATION CODE 1 through OPERATION CODE 25
- +9 ;
- +10 ;Census records are not indexed.
- +11 IF $PIECE(^DGPT(DA(1),0),U,11)=2
- QUIT
- +12 NEW CODE,CODESYS,DAS,DFN,NNAME,LOCATION
- +13 SET DFN=$PIECE(^DGPT(DA(1),0),U,1)
- +14 SET NNAME=NODE_NUM
- +15 ;401 OPERATION CODE 1 through 20 on 0 node, OPERATION CODE 21 through 25 on 1 node
- +16 ;601 PROCEDURE 1 through 20 on 0 node, PROCEDURE CODE 21 through 25 on 1 node
- +17 SET LOCATION=$SELECT(NUM<21:0,1:1)
- +18 SET DAS=DA(1)_";"_NODE_";"_DA_";"_LOCATION
- +19 SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80.1,X(2))),U,3)
- +20 SET CODE=$$CODEC^ICDEX(80.1,X(2))
- +21 SET ^PXRMINDX(45,CODESYS,"INP",CODE,NNAME,DFN,X(1),DAS)=""
- +22 SET ^PXRMINDX(45,CODESYS,"PNI",DFN,NNAME,CODE,X(1),DAS)=""
- +23 QUIT