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 Dec 13, 2024@02:51:56 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
