DGPTIC10 ;ALB/AAS/PLT - PTF API TO ICD10 Remediation calls ;9/29/2011
;;5.3;Registration;**850,905,884**;Aug 13, 1993;Build 31
;;Per VA Directive 6402, this routine should not be modified.
QUIT
;
; CODEC^ICDEX ICR 5747
; VLT^ICDEX ICR 5747
;
GETCODSY(CSYS,IEN,DATE) ; -- RETURN IF THIS IS ICD9 OR ICD10
; returns 20th piece of call to ICDDATA^ICDxcode
Q $P($$ICDDATA^ICDXCODE(CSYS,IEN,DATE),"^",20)
;
;; ICDINFO^DGAPI
;
IMPDATE(CODESYS) ; - calls IMPDATE^LEXU(CODESYS)
; CODESYS: 10D = diagnosis, 10P = procedure
I $G(CODESYS)="" S CODESYS="10D"
QUIT $$IMPDATE^LEXU($G(CODESYS))
;
;
EFFDATE(DGPTF,DGTYPE,DGMOVE,DGCSYS) ;-- build ICD-10 Implementation date / effective date
N DGTEMP,X,Y,I,J,DGFEE
S:$G(DGTYPE)="" DGTYPE=$P($G(X1),U,2)
I $G(DGCSYS)="" S DGCSYS="10D"
I $G(DGPTF)="" S (DGPTDAT,EFFDATE)=DT G EQ
I $G(DGTYPE)="" S DGTYPE="701"
I (DGTYPE'="501")&(DGTYPE'="601")&(DGTYPE'="701")&(DGTYPE'="801") S DGTYPE="701"
I $G(DGMOVE)="" S DGMOVE=1
;Add 801 logic - uses CPT/Record date for EFFDATE
S:DGTYPE'="801" (DGPTDAT,EFFDATE)=$$GET7DATE^DGPTIC10(DGPTF)
S:DGTYPE="801" (DGPTDAT,DGCPTDT,EFFDATE)=$$GET8DATE($G(DGPTF))
EQ S DGTEMP=$$IMPDATE^DGPTIC10(DGCSYS)
S IMPDATE=$P(DGTEMP,U,1)
;piece 2 of dgtemp has no 7n value and code below removed
;I DGPTDAT'<IMPDATE,+$P(DGTEMP,U,2)?7N S EFFDATE=+$P(DGTEMP,U,2)
Q
;
EFFDAT1(DGPTDAT) ;-- build ICD-10 Implementation date / effective date
N DGTEMP,DGFEE
Q:$G(DGPTDAT)=""
S DGTEMP=$$IMPDATE^DGPTIC10("10D")
S EFFDATE=+$E(DGPTDAT,1,7)
S IMPDATE=$P(DGTEMP,U,1)
I DGPTDAT'<IMPDATE,+$P(DGTEMP,U,2)?7N S EFFDATE=+$P(DGTEMP,U,2)
Q
;
CODESYS(PTFIEN) ; returns coding system for a PTF Based on Discharge Date
; -- called from DG701 template
N DISDATE,X,Y,DGFEE
I '$D(^DGPT($G(PTFIEN),0)) Q $$GETCODS("10D",DT)
;
; -- Census Date
; -- Currently a census record
S PTR=$P($G(^DGPT(PTFIEN,0)),U,13) I PTR'="" S DISDATE=$P($G(^DG(45.86,PTR,0)),U,1) G:DISDATE'="" CSQ
; -- requires a census
S PTF=PTFIEN D:'$D(DGPMCA) PM^DGPTUTL ; -- gets admission in DGPMCA and 0th node in DGPMAN
N DGSAVE S DGSAVE=$G(DGPTF0) D CEN^DGPTC1 S DGPTF0=DGSAVE
; -- DGCST=Census Status, dgcn=ien of census date file
I $D(DGCST),DGCST=0,DGCN>0 S DISDATE=$P($G(^DG(45.86,DGCN,0)),U,1) G:DISDATE?7N CSQ
;
S DISDATE=+$E($P($G(^DGPT($G(PTFIEN),70)),"^",1),1,7)
I DISDATE<1 S DISDATE=DT
CSQ Q $$GETCODS("10D",DISDATE)
;
GETCODS(CODESYS,DATE) ; - Returns coding system for a date
N IMPDATE,VERSION,DGFEE
S IMPDATE=+$$IMPDATE(CODESYS)
I +IMPDATE>0 D
. I DATE<IMPDATE S VERSION="ICD9" Q
. I DATE'<IMPDATE S VERSION="ICD10"
I $G(VERSION)'="" Q VERSION
Q "ICD9"
;
GET8DATE(PATNUM) ; GET CPT RECORD DATE FOR 801 SERVICE
S EFFD=+$G(DGPRD)
I EFFD="",$G(DGZP),$D(^DGPT(PATNUM,"C",DGZP,0))#10 S EFFD=+^DGPT(PATNUM,"C",DGZP,0)
S:EFFD="" EFFD=DT
Q $P(EFFD,U,1)
;
GET7DATE(PATNUM) ; FROM icdgtdrg
;Find the correct "EFFECTIVE DATE" for locating the icd codes for 701 fields
;
; Input: PATNUM - PTF Record Number
; Output: "effective date" to use
;
N EFFD,PTR,IMPDATE,ADMDATE,PTF,X,Y,DGFEE
S ADMDATE=$P($G(^DGPT(PATNUM,0)),U,2)
;
; -- Census Date
; -- Currently a census record
S PTR=$P($G(^DGPT(PATNUM,0)),U,13) I PTR'="" S EFFD=$P($G(^DG(45.86,PTR,0)),U,1) G:EFFD'="" G7OUT
; -- requires a census
S PTF=PATNUM D:'$D(DGPMCA) PM^DGPTUTL ; -- gets admission in DGPMCA and 0th node in DGPMAN
N DGSAVE S DGSAVE=$G(DGPTF0) D CEN^DGPTC1 S DGPTF0=DGSAVE
; -- DGCST=Census Status, dgcn=ien of census date file
I $D(DGCST),DGCST=0,DGCN>0 S EFFD=$P($G(^DG(45.86,DGCN,0)),U,1) G:EFFD?7N G7OUT
;
; Discharge Date
S DISDATE=$E($P($G(^DGPT(PATNUM,70)),U,1),1,7)
I DISDATE'="" S EFFD=$P(DISDATE,".") G G7OUT
I DISDATE="" S EFFD=DT G G7OUT
; Default TODAY
I $G(EFFD)="" S EFFD=DT
G7OUT Q EFFD
;
GET5DATE(PATNUM,MOVE) ; FROM icdgtdrg
;Find the correct "EFFECTIVE DATE" for locating the icd codes for 501 fields
;
; Input: PATNUM - PTF Record Number
; MOVE - PTF Movement Number
; Output: "effective date" to use
;
N EFFD,PTR,IMPDATE,MOVDATE,X,Y,DGFEE
; Census Date
S PTR=$P($G(^DGPT(PATNUM,0)),U,13) I PTR'="" S EFFD=$P($G(^DG(45.86,PTR,0)),U,1) G:EFFD'="" G5OUT
; -- requires a census
S PTF=PATNUM D:'$D(DGPMCA) PM^DGPTUTL ; -- gets admission in DGPMCA and 0th node in DGPMAN
N DGSAVE S DGSAVE=$G(DGPTF0) D CEN^DGPTC1 S DGPTF0=DGSAVE
; -- DGCST=Census Status, dgcn=ien of census date file
I $D(DGCST),DGCST=0,DGCN>0 S EFFD=$P($G(^DG(45.86,DGCN,0)),U,1) G:EFFD?7N G7OUT
;
; Discharge Date
S DISDATE=$E($P($G(^DGPT(PATNUM,70)),U,1),1,7)
S MOVDATE=$P($G(^DGPT(PATNUM,"M",MOVE,0)),U,10)
I DISDATE'="" S EFFD=$P(DISDATE,".") G G5OUT
; Default TODAY
S EFFD=DT
G5OUT ;
Q EFFD
;
GET6DATE(PATNUM,PROC,DGI) ; FROM icdgtdrg
;Find the correct "EFFECTIVE DATE" for locating the icd codes for 601 fields
;
; Input: PATNUM - PTF Record Number
; PROC - Procedure or Surgery number
; DGI - 5- PROCEDURE NODE, 8 = SURGERY NODE
; Output: "effective date" to use
;
N EFFD,PTR,IMPDATE,MOVDATE,X,Y,DGFEE
I '$G(PATNUM) S PATNUM=$G(PROC)
I '$G(PATNUM) S EFFD=DT G G6OUT
; Census Date
S PTR=$P($G(^DGPT(PATNUM,0)),U,13) I PTR'="" S EFFD=$P($G(^DG(45.86,PTR,0)),U,1) G:EFFD'="" G6OUT
; -- requires a census
S PTF=PATNUM D:'$D(DGPMCA) PM^DGPTUTL ; -- gets admission in DGPMCA and 0th node in DGPMAN
N DGSAVE S DGSAVE=$G(DGPTF0) D CEN^DGPTC1 S DGPTF0=DGSAVE
; -- DGCST=Census Status, dgcn=ien of census date file
I $D(DGCST),DGCST=0,DGCN>0 S EFFD=$P($G(^DG(45.86,DGCN,0)),U,1) G:EFFD?7N G7OUT ; DGCNO=0th node
;
; Discharge Date
S DISDATE=$E($P($G(^DGPT(PATNUM,70)),U,1),1,7)
;
I $G(DGI)=1 S MOVDATE=$S(DISDATE'="":DISDATE,1:DT)
I $G(DGI)=5 S MOVDATE=$P($G(^DGPT(PATNUM,"P",PROC,0)),U,1)
I $G(DGI)=8 S MOVDATE=$P($G(^DGPT(PATNUM,"S",PROC,0)),U,1)
I DISDATE'="" S EFFD=$P(DISDATE,".") G G6OUT
S EFFD=DT
G6OUT ;
Q EFFD
;
GETCDATE(PATNUM,CPT) ;
;Find the correct "EFFECTIVE DATE" for CPT Procedures
;
; Input: PATNUM - PTF Record Number
; cpt - CPT Entry Number
; Output: "effective date" to use
;
N EFFD,PTR,IMPDATE,MOVDATE,X,Y,DGFEE
; Census Date
S PTR=$P($G(^DGPT(PATNUM,0)),U,13) I PTR'="" S EFFD=$P($G(^DG(45.86,PTR,0)),U,1) G:EFFD'="" GCOUT
; -- requires a census
S PTF=PATNUM D:'$D(DGPMCA) PM^DGPTUTL ; -- gets admission in DGPMCA and 0th node in DGPMAN
N DGSAVE S DGSAVE=$G(DGPTF0) D CEN^DGPTC1 S DGPTF0=DGSAVE
; -- DGCST=Census Status, dgcn=ien of census date file
I $D(DGCST),DGCST=0,DGCN>0 S EFFD=$P($G(^DG(45.86,DGCN,0)),U,1) G:EFFD?7N G7OUT
;
; Discharge Date
S DISDATE=$E($P($G(^DGPT(PATNUM,70)),U,1),1,7)
I DISDATE'="" S EFFD=$P(DISDATE,".") G GCOUT
; Default TODAY
S EFFD=DT
GCOUT ;
Q EFFD
;
GETLABEL(EVDATE,CODESYS) ; returns ICD label for printing
; CODESYS - D for diagnosis or P for Procedures
; EVDATE - event date to use for determine label (discharge, movement date, etc.
N ICDVER
S ICDVER=""
I CODESYS="D" S ICDVER=" (ICD-10-CM)" I EVDATE<$P($$IMPDATE("10D"),U,1) S ICDVER=" (ICD-9-CM)"
I CODESYS="P" S ICDVER=" (ICD-10-PCS)" I EVDATE<$P($$IMPDATE("10P"),U,1) S ICDVER=" (ICD-9-CM)"
Q ICDVER
;
DISPLY(FILE,IEN,DATE,FRMT) ; -- return the Code - Description for a code
N CODE,DESC
I $G(FILE)="DIAG"!($G(FILE)="ICD")!($G(FILE)="10D") S FILE=80
I $G(FILE)="PROC"!($G(FILE)="ICP")!($G(FILE)="10P") S FILE=80.1
I $G(FILE)'=80&($G(FILE)'=80.1) Q ""
I $G(IEN)<1 Q ""
I $G(FRMT)="" S FRMT=1
I FRMT'=1&(FRMT'=2) S FRMT=1
S CODE=$$CODEC^ICDEX(FILE,IEN)
S DESC=$$VLT^ICDEX(FILE,IEN,$G(DATE))
;
I $G(CODE)=""!($P($G(CODE),"^")=-1) S CODE="****"
I $G(DESC)=""!($P($G(DESC),"^")=-1) S DESC="********************"
I $G(FRMT)=1 Q $E(CODE_" ",1,9)_DESC
I $G(FRMT)=2 Q DESC_"("_CODE_")"
Q "**** **********************"
;
WRITECOD(FILE,IEN,DATE,FRMT,RETURN,TAB) ;
N I,X,X1,DGIOM,TAB1,TAB2,DGPARSE,DGPARSE2,DGSPACE,SIZE,DGSPACE2
S TAB=+$G(TAB),RETURN=+$G(RETURN)
S:TAB>20 TAB=20
S SIZE=$S(TAB<1:4,1:TAB)
S RETURN=$S(RETURN=0:"$C(0)",RETURN=1:"!",RETURN=2:"!!",RETURN=3:"!!!",1:"!")
S DGIOM=+$G(IOM) I DGIOM<40 S DGIOM=80
;
S X=$$DISPLY($G(FILE),$G(IEN),$G(DATE),$G(FRMT))
I ($L(X)+SIZE)<DGIOM W @RETURN,?TAB,X Q
;
S DGPARSE=DGIOM-TAB ; Find the place to start moving backwards looking for a space
I TAB<1 S DGPARSE=DGPARSE-4
;
F I=DGPARSE:-1:10 I $E(X,I)=" " Q
S DGSPACE=I ; this is the space
;
I FRMT=1 S TAB1=$F(X," ") D
. S I=0 F S I=$F(X," ",TAB1) Q:I'=(TAB1+1) S TAB1=I
. S TAB2=TAB1+1
I FRMT'=1 S TAB2=TAB+3
;
I ($L(X)+SIZE)>79 W @RETURN,?TAB,$E(X,1,DGSPACE) D
. I (TAB2+$L($E(X,DGSPACE+1,$L(X))))<DGIOM D Q
.. W !,?TAB2," ",$E(X,DGSPACE+1,$L(X))
. ;
. S DGPARSE=DGIOM-TAB2-3
. S X1=$E(X,DGSPACE+1,$L(X))
. ;
. F I=DGPARSE:-1:1 I $E(X1,I)=" " Q
. S DGSPACE2=I
. W !,?TAB2," ",$E(X1,1,DGSPACE2)
. W !,?TAB2," ",$E(X1,DGSPACE2+1,$L(X1)) Q
Q
;
PREV ;
Q
;
ICDNAME() ; -- Called from PTF EXPANDED CODE file (45.89) field Name (#200)
; -- Determines ICD Code name using supported API's
; Replaces direct global reads in computed Expression
;
Q:'+$G(D0)&'+$G(DA)
I '+$G(D0) S D0=DA
N ENTRY,TYPE,X
S X=""
S ENTRY=$P($G(^DIC(45.89,D0,0)),U,2),VERSION=$P($G(^DIC(45.89,D0,0)),U,5)
Q:'+$G(ENTRY) X
S TYPE=$P(ENTRY,";",2),VERSION=$P(^DIC(45.89,D0,0),U,5)
I TYPE="ICD9(" S X=$$VLT^ICDEX(80,+ENTRY)
I TYPE="ICD0(" S X=$$VLT^ICDEX(80.1,+ENTRY)
Q X
;
INPUT() ; - Input transform for 27.27;9 S X=$$INPUT^DGPTIC10() K:X<1 X
N ICDVER,CAT
S CAT=$P(^(0),U,2) S Y(0)=$S(CAT="D":80,CAT-"P":80.1,1:"")
S ICDVER=$S(CAT="D":"10D",1:"10P")
D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
Q X
DATERANG ; Get an ICD-10 compliant date range
N IMPDATE,DGSDATE ;
S IMPDATE=+$$IMPDATE^DGPTIC10("10D")
W !!,"ICD-10 Implementation Date: ",$$FMTE^XLFDT(IMPDATE),!
S DGSDATE=$$SDAT() G:DGSDATE<1 DRQ
S DGEDATE=$$TDAT(DGSDATE)
;G:EDATE<1 DRQ
DRQ ;
;
SDAT() ; ask for start date
N Y,DIR,DTOUT,DUOUT
S DIR(0)="D^:"_DT_":EX",DIR("A")="Start Date"
D ^DIR K DIR
Q:$D(DTOUT)!($D(DUOUT)) -1
Q Y
TDAT(DGSDAT) ; ask for end date
N Y,DIR,DTOUT,DUOUT
S DIR(0)="D^"_DGSDAT_":"_DT_":EX",DIR("A")="End Date"
I '$D(IMPDATE) S IMPDATE=+$$IMPDATE^DGPTIC10("10D")
I DGSDAT<IMPDATE,DT'<IMPDATE D
. W !!,?10,"Start date is before ICD-10 implementation.",!,?10,"End date must be before ICD-10 implementation",!
. S DIR(0)="D^"_DGSDAT_":"_$$FMADD^XLFDT(IMPDATE,-1)_":EX"
D ^DIR K DIR
Q:$D(DTOUT)!($D(DUOUT)) -1
Q Y
;
CENSUS(DGPTF) ; display warning to user for ICD-10 transition census records
;this census subroutine call displaying a warning message is disabled
;and is not used for the icd-10 implementation period.
; -- do not remove this procedure from the routine
; -- called by input templates DG401, DG501, DG501F, DG601, and DG701
;
;
Q
N X,Y,CENDATE,EFFDATE,IMPDATE,DGPTDAT
;
Q:'$D(PTF) ; -- Called directly from fileman, no variable set up.
;
; -- Get census status (DGCST) and ien of census date (DGCN)
N DGSAVE S DGSAVE=$G(DGPTF0) D CEN^DGPTC1 S DGPTF0=DGSAVE
;
I '$D(DGCST) G CENSUSQ
I $G(DGCST)>0 G CENSUSQ ; status no longer open
;
; -- DGCST=Census Status, dgcn=ien of census date file
I $D(DGCST),DGCST=0,DGCN>0 S CENDATE=$P($G(^DG(45.86,DGCN,0)),U,1)
D EFFDATE(DGPTF)
I CENDATE<IMPDATE,DT'<IMPDATE D
. W !!,?5,"Note: This PTF record is OPEN for CENSUS."
. W !,?7,"Census requires ICD-9 codes."
. W !,?7,"PTF will require ICD-10 codes after the census is closed.",!
CENSUSQ ;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTIC10 11718 printed Sep 23, 2025@20:28:38 Page 2
DGPTIC10 ;ALB/AAS/PLT - PTF API TO ICD10 Remediation calls ;9/29/2011
+1 ;;5.3;Registration;**850,905,884**;Aug 13, 1993;Build 31
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ; CODEC^ICDEX ICR 5747
+6 ; VLT^ICDEX ICR 5747
+7 ;
GETCODSY(CSYS,IEN,DATE) ; -- RETURN IF THIS IS ICD9 OR ICD10
+1 ; returns 20th piece of call to ICDDATA^ICDxcode
+2 QUIT $PIECE($$ICDDATA^ICDXCODE(CSYS,IEN,DATE),"^",20)
+3 ;
+4 ;; ICDINFO^DGAPI
+5 ;
IMPDATE(CODESYS) ; - calls IMPDATE^LEXU(CODESYS)
+1 ; CODESYS: 10D = diagnosis, 10P = procedure
+2 IF $GET(CODESYS)=""
SET CODESYS="10D"
+3 QUIT $$IMPDATE^LEXU($GET(CODESYS))
+4 ;
+5 ;
EFFDATE(DGPTF,DGTYPE,DGMOVE,DGCSYS) ;-- build ICD-10 Implementation date / effective date
+1 NEW DGTEMP,X,Y,I,J,DGFEE
+2 if $GET(DGTYPE)=""
SET DGTYPE=$PIECE($GET(X1),U,2)
+3 IF $GET(DGCSYS)=""
SET DGCSYS="10D"
+4 IF $GET(DGPTF)=""
SET (DGPTDAT,EFFDATE)=DT
GOTO EQ
+5 IF $GET(DGTYPE)=""
SET DGTYPE="701"
+6 IF (DGTYPE'="501")&(DGTYPE'="601")&(DGTYPE'="701")&(DGTYPE'="801")
SET DGTYPE="701"
+7 IF $GET(DGMOVE)=""
SET DGMOVE=1
+8 ;Add 801 logic - uses CPT/Record date for EFFDATE
+9 if DGTYPE'="801"
SET (DGPTDAT,EFFDATE)=$$GET7DATE^DGPTIC10(DGPTF)
+10 if DGTYPE="801"
SET (DGPTDAT,DGCPTDT,EFFDATE)=$$GET8DATE($GET(DGPTF))
EQ SET DGTEMP=$$IMPDATE^DGPTIC10(DGCSYS)
+1 SET IMPDATE=$PIECE(DGTEMP,U,1)
+2 ;piece 2 of dgtemp has no 7n value and code below removed
+3 ;I DGPTDAT'<IMPDATE,+$P(DGTEMP,U,2)?7N S EFFDATE=+$P(DGTEMP,U,2)
+4 QUIT
+5 ;
EFFDAT1(DGPTDAT) ;-- build ICD-10 Implementation date / effective date
+1 NEW DGTEMP,DGFEE
+2 if $GET(DGPTDAT)=""
QUIT
+3 SET DGTEMP=$$IMPDATE^DGPTIC10("10D")
+4 SET EFFDATE=+$EXTRACT(DGPTDAT,1,7)
+5 SET IMPDATE=$PIECE(DGTEMP,U,1)
+6 IF DGPTDAT'<IMPDATE
IF +$PIECE(DGTEMP,U,2)?7N
SET EFFDATE=+$PIECE(DGTEMP,U,2)
+7 QUIT
+8 ;
CODESYS(PTFIEN) ; returns coding system for a PTF Based on Discharge Date
+1 ; -- called from DG701 template
+2 NEW DISDATE,X,Y,DGFEE
+3 IF '$DATA(^DGPT($GET(PTFIEN),0))
QUIT $$GETCODS("10D",DT)
+4 ;
+5 ; -- Census Date
+6 ; -- Currently a census record
+7 SET PTR=$PIECE($GET(^DGPT(PTFIEN,0)),U,13)
IF PTR'=""
SET DISDATE=$PIECE($GET(^DG(45.86,PTR,0)),U,1)
if DISDATE'=""
GOTO CSQ
+8 ; -- requires a census
+9 ; -- gets admission in DGPMCA and 0th node in DGPMAN
SET PTF=PTFIEN
if '$DATA(DGPMCA)
DO PM^DGPTUTL
+10 NEW DGSAVE
SET DGSAVE=$GET(DGPTF0)
DO CEN^DGPTC1
SET DGPTF0=DGSAVE
+11 ; -- DGCST=Census Status, dgcn=ien of census date file
+12 IF $DATA(DGCST)
IF DGCST=0
IF DGCN>0
SET DISDATE=$PIECE($GET(^DG(45.86,DGCN,0)),U,1)
if DISDATE?7N
GOTO CSQ
+13 ;
+14 SET DISDATE=+$EXTRACT($PIECE($GET(^DGPT($GET(PTFIEN),70)),"^",1),1,7)
+15 IF DISDATE<1
SET DISDATE=DT
CSQ QUIT $$GETCODS("10D",DISDATE)
+1 ;
GETCODS(CODESYS,DATE) ; - Returns coding system for a date
+1 NEW IMPDATE,VERSION,DGFEE
+2 SET IMPDATE=+$$IMPDATE(CODESYS)
+3 IF +IMPDATE>0
Begin DoDot:1
+4 IF DATE<IMPDATE
SET VERSION="ICD9"
QUIT
+5 IF DATE'<IMPDATE
SET VERSION="ICD10"
End DoDot:1
+6 IF $GET(VERSION)'=""
QUIT VERSION
+7 QUIT "ICD9"
+8 ;
GET8DATE(PATNUM) ; GET CPT RECORD DATE FOR 801 SERVICE
+1 SET EFFD=+$GET(DGPRD)
+2 IF EFFD=""
IF $GET(DGZP)
IF $DATA(^DGPT(PATNUM,"C",DGZP,0))#10
SET EFFD=+^DGPT(PATNUM,"C",DGZP,0)
+3 if EFFD=""
SET EFFD=DT
+4 QUIT $PIECE(EFFD,U,1)
+5 ;
GET7DATE(PATNUM) ; FROM icdgtdrg
+1 ;Find the correct "EFFECTIVE DATE" for locating the icd codes for 701 fields
+2 ;
+3 ; Input: PATNUM - PTF Record Number
+4 ; Output: "effective date" to use
+5 ;
+6 NEW EFFD,PTR,IMPDATE,ADMDATE,PTF,X,Y,DGFEE
+7 SET ADMDATE=$PIECE($GET(^DGPT(PATNUM,0)),U,2)
+8 ;
+9 ; -- Census Date
+10 ; -- Currently a census record
+11 SET PTR=$PIECE($GET(^DGPT(PATNUM,0)),U,13)
IF PTR'=""
SET EFFD=$PIECE($GET(^DG(45.86,PTR,0)),U,1)
if EFFD'=""
GOTO G7OUT
+12 ; -- requires a census
+13 ; -- gets admission in DGPMCA and 0th node in DGPMAN
SET PTF=PATNUM
if '$DATA(DGPMCA)
DO PM^DGPTUTL
+14 NEW DGSAVE
SET DGSAVE=$GET(DGPTF0)
DO CEN^DGPTC1
SET DGPTF0=DGSAVE
+15 ; -- DGCST=Census Status, dgcn=ien of census date file
+16 IF $DATA(DGCST)
IF DGCST=0
IF DGCN>0
SET EFFD=$PIECE($GET(^DG(45.86,DGCN,0)),U,1)
if EFFD?7N
GOTO G7OUT
+17 ;
+18 ; Discharge Date
+19 SET DISDATE=$EXTRACT($PIECE($GET(^DGPT(PATNUM,70)),U,1),1,7)
+20 IF DISDATE'=""
SET EFFD=$PIECE(DISDATE,".")
GOTO G7OUT
+21 IF DISDATE=""
SET EFFD=DT
GOTO G7OUT
+22 ; Default TODAY
+23 IF $GET(EFFD)=""
SET EFFD=DT
G7OUT QUIT EFFD
+1 ;
GET5DATE(PATNUM,MOVE) ; FROM icdgtdrg
+1 ;Find the correct "EFFECTIVE DATE" for locating the icd codes for 501 fields
+2 ;
+3 ; Input: PATNUM - PTF Record Number
+4 ; MOVE - PTF Movement Number
+5 ; Output: "effective date" to use
+6 ;
+7 NEW EFFD,PTR,IMPDATE,MOVDATE,X,Y,DGFEE
+8 ; Census Date
+9 SET PTR=$PIECE($GET(^DGPT(PATNUM,0)),U,13)
IF PTR'=""
SET EFFD=$PIECE($GET(^DG(45.86,PTR,0)),U,1)
if EFFD'=""
GOTO G5OUT
+10 ; -- requires a census
+11 ; -- gets admission in DGPMCA and 0th node in DGPMAN
SET PTF=PATNUM
if '$DATA(DGPMCA)
DO PM^DGPTUTL
+12 NEW DGSAVE
SET DGSAVE=$GET(DGPTF0)
DO CEN^DGPTC1
SET DGPTF0=DGSAVE
+13 ; -- DGCST=Census Status, dgcn=ien of census date file
+14 IF $DATA(DGCST)
IF DGCST=0
IF DGCN>0
SET EFFD=$PIECE($GET(^DG(45.86,DGCN,0)),U,1)
if EFFD?7N
GOTO G7OUT
+15 ;
+16 ; Discharge Date
+17 SET DISDATE=$EXTRACT($PIECE($GET(^DGPT(PATNUM,70)),U,1),1,7)
+18 SET MOVDATE=$PIECE($GET(^DGPT(PATNUM,"M",MOVE,0)),U,10)
+19 IF DISDATE'=""
SET EFFD=$PIECE(DISDATE,".")
GOTO G5OUT
+20 ; Default TODAY
+21 SET EFFD=DT
G5OUT ;
+1 QUIT EFFD
+2 ;
GET6DATE(PATNUM,PROC,DGI) ; FROM icdgtdrg
+1 ;Find the correct "EFFECTIVE DATE" for locating the icd codes for 601 fields
+2 ;
+3 ; Input: PATNUM - PTF Record Number
+4 ; PROC - Procedure or Surgery number
+5 ; DGI - 5- PROCEDURE NODE, 8 = SURGERY NODE
+6 ; Output: "effective date" to use
+7 ;
+8 NEW EFFD,PTR,IMPDATE,MOVDATE,X,Y,DGFEE
+9 IF '$GET(PATNUM)
SET PATNUM=$GET(PROC)
+10 IF '$GET(PATNUM)
SET EFFD=DT
GOTO G6OUT
+11 ; Census Date
+12 SET PTR=$PIECE($GET(^DGPT(PATNUM,0)),U,13)
IF PTR'=""
SET EFFD=$PIECE($GET(^DG(45.86,PTR,0)),U,1)
if EFFD'=""
GOTO G6OUT
+13 ; -- requires a census
+14 ; -- gets admission in DGPMCA and 0th node in DGPMAN
SET PTF=PATNUM
if '$DATA(DGPMCA)
DO PM^DGPTUTL
+15 NEW DGSAVE
SET DGSAVE=$GET(DGPTF0)
DO CEN^DGPTC1
SET DGPTF0=DGSAVE
+16 ; -- DGCST=Census Status, dgcn=ien of census date file
+17 ; DGCNO=0th node
IF $DATA(DGCST)
IF DGCST=0
IF DGCN>0
SET EFFD=$PIECE($GET(^DG(45.86,DGCN,0)),U,1)
if EFFD?7N
GOTO G7OUT
+18 ;
+19 ; Discharge Date
+20 SET DISDATE=$EXTRACT($PIECE($GET(^DGPT(PATNUM,70)),U,1),1,7)
+21 ;
+22 IF $GET(DGI)=1
SET MOVDATE=$SELECT(DISDATE'="":DISDATE,1:DT)
+23 IF $GET(DGI)=5
SET MOVDATE=$PIECE($GET(^DGPT(PATNUM,"P",PROC,0)),U,1)
+24 IF $GET(DGI)=8
SET MOVDATE=$PIECE($GET(^DGPT(PATNUM,"S",PROC,0)),U,1)
+25 IF DISDATE'=""
SET EFFD=$PIECE(DISDATE,".")
GOTO G6OUT
+26 SET EFFD=DT
G6OUT ;
+1 QUIT EFFD
+2 ;
GETCDATE(PATNUM,CPT) ;
+1 ;Find the correct "EFFECTIVE DATE" for CPT Procedures
+2 ;
+3 ; Input: PATNUM - PTF Record Number
+4 ; cpt - CPT Entry Number
+5 ; Output: "effective date" to use
+6 ;
+7 NEW EFFD,PTR,IMPDATE,MOVDATE,X,Y,DGFEE
+8 ; Census Date
+9 SET PTR=$PIECE($GET(^DGPT(PATNUM,0)),U,13)
IF PTR'=""
SET EFFD=$PIECE($GET(^DG(45.86,PTR,0)),U,1)
if EFFD'=""
GOTO GCOUT
+10 ; -- requires a census
+11 ; -- gets admission in DGPMCA and 0th node in DGPMAN
SET PTF=PATNUM
if '$DATA(DGPMCA)
DO PM^DGPTUTL
+12 NEW DGSAVE
SET DGSAVE=$GET(DGPTF0)
DO CEN^DGPTC1
SET DGPTF0=DGSAVE
+13 ; -- DGCST=Census Status, dgcn=ien of census date file
+14 IF $DATA(DGCST)
IF DGCST=0
IF DGCN>0
SET EFFD=$PIECE($GET(^DG(45.86,DGCN,0)),U,1)
if EFFD?7N
GOTO G7OUT
+15 ;
+16 ; Discharge Date
+17 SET DISDATE=$EXTRACT($PIECE($GET(^DGPT(PATNUM,70)),U,1),1,7)
+18 IF DISDATE'=""
SET EFFD=$PIECE(DISDATE,".")
GOTO GCOUT
+19 ; Default TODAY
+20 SET EFFD=DT
GCOUT ;
+1 QUIT EFFD
+2 ;
GETLABEL(EVDATE,CODESYS) ; returns ICD label for printing
+1 ; CODESYS - D for diagnosis or P for Procedures
+2 ; EVDATE - event date to use for determine label (discharge, movement date, etc.
+3 NEW ICDVER
+4 SET ICDVER=""
+5 IF CODESYS="D"
SET ICDVER=" (ICD-10-CM)"
IF EVDATE<$PIECE($$IMPDATE("10D"),U,1)
SET ICDVER=" (ICD-9-CM)"
+6 IF CODESYS="P"
SET ICDVER=" (ICD-10-PCS)"
IF EVDATE<$PIECE($$IMPDATE("10P"),U,1)
SET ICDVER=" (ICD-9-CM)"
+7 QUIT ICDVER
+8 ;
DISPLY(FILE,IEN,DATE,FRMT) ; -- return the Code - Description for a code
+1 NEW CODE,DESC
+2 IF $GET(FILE)="DIAG"!($GET(FILE)="ICD")!($GET(FILE)="10D")
SET FILE=80
+3 IF $GET(FILE)="PROC"!($GET(FILE)="ICP")!($GET(FILE)="10P")
SET FILE=80.1
+4 IF $GET(FILE)'=80&($GET(FILE)'=80.1)
QUIT ""
+5 IF $GET(IEN)<1
QUIT ""
+6 IF $GET(FRMT)=""
SET FRMT=1
+7 IF FRMT'=1&(FRMT'=2)
SET FRMT=1
+8 SET CODE=$$CODEC^ICDEX(FILE,IEN)
+9 SET DESC=$$VLT^ICDEX(FILE,IEN,$GET(DATE))
+10 ;
+11 IF $GET(CODE)=""!($PIECE($GET(CODE),"^")=-1)
SET CODE="****"
+12 IF $GET(DESC)=""!($PIECE($GET(DESC),"^")=-1)
SET DESC="********************"
+13 IF $GET(FRMT)=1
QUIT $EXTRACT(CODE_" ",1,9)_DESC
+14 IF $GET(FRMT)=2
QUIT DESC_"("_CODE_")"
+15 QUIT "**** **********************"
+16 ;
WRITECOD(FILE,IEN,DATE,FRMT,RETURN,TAB) ;
+1 NEW I,X,X1,DGIOM,TAB1,TAB2,DGPARSE,DGPARSE2,DGSPACE,SIZE,DGSPACE2
+2 SET TAB=+$GET(TAB)
SET RETURN=+$GET(RETURN)
+3 if TAB>20
SET TAB=20
+4 SET SIZE=$SELECT(TAB<1:4,1:TAB)
+5 SET RETURN=$SELECT(RETURN=0:"$C(0)",RETURN=1:"!",RETURN=2:"!!",RETURN=3:"!!!",1:"!")
+6 SET DGIOM=+$GET(IOM)
IF DGIOM<40
SET DGIOM=80
+7 ;
+8 SET X=$$DISPLY($GET(FILE),$GET(IEN),$GET(DATE),$GET(FRMT))
+9 IF ($LENGTH(X)+SIZE)<DGIOM
WRITE @RETURN,?TAB,X
QUIT
+10 ;
+11 ; Find the place to start moving backwards looking for a space
SET DGPARSE=DGIOM-TAB
+12 IF TAB<1
SET DGPARSE=DGPARSE-4
+13 ;
+14 FOR I=DGPARSE:-1:10
IF $EXTRACT(X,I)=" "
QUIT
+15 ; this is the space
SET DGSPACE=I
+16 ;
+17 IF FRMT=1
SET TAB1=$FIND(X," ")
Begin DoDot:1
+18 SET I=0
FOR
SET I=$FIND(X," ",TAB1)
if I'=(TAB1+1)
QUIT
SET TAB1=I
+19 SET TAB2=TAB1+1
End DoDot:1
+20 IF FRMT'=1
SET TAB2=TAB+3
+21 ;
+22 IF ($LENGTH(X)+SIZE)>79
WRITE @RETURN,?TAB,$EXTRACT(X,1,DGSPACE)
Begin DoDot:1
+23 IF (TAB2+$LENGTH($EXTRACT(X,DGSPACE+1,$LENGTH(X))))<DGIOM
Begin DoDot:2
+24 WRITE !,?TAB2," ",$EXTRACT(X,DGSPACE+1,$LENGTH(X))
End DoDot:2
QUIT
+25 ;
+26 SET DGPARSE=DGIOM-TAB2-3
+27 SET X1=$EXTRACT(X,DGSPACE+1,$LENGTH(X))
+28 ;
+29 FOR I=DGPARSE:-1:1
IF $EXTRACT(X1,I)=" "
QUIT
+30 SET DGSPACE2=I
+31 WRITE !,?TAB2," ",$EXTRACT(X1,1,DGSPACE2)
+32 WRITE !,?TAB2," ",$EXTRACT(X1,DGSPACE2+1,$LENGTH(X1))
QUIT
End DoDot:1
+33 QUIT
+34 ;
PREV ;
+1 QUIT
+2 ;
ICDNAME() ; -- Called from PTF EXPANDED CODE file (45.89) field Name (#200)
+1 ; -- Determines ICD Code name using supported API's
+2 ; Replaces direct global reads in computed Expression
+3 ;
+4 if '+$GET(D0)&'+$GET(DA)
QUIT
+5 IF '+$GET(D0)
SET D0=DA
+6 NEW ENTRY,TYPE,X
+7 SET X=""
+8 SET ENTRY=$PIECE($GET(^DIC(45.89,D0,0)),U,2)
SET VERSION=$PIECE($GET(^DIC(45.89,D0,0)),U,5)
+9 if '+$GET(ENTRY)
QUIT X
+10 SET TYPE=$PIECE(ENTRY,";",2)
SET VERSION=$PIECE(^DIC(45.89,D0,0),U,5)
+11 IF TYPE="ICD9("
SET X=$$VLT^ICDEX(80,+ENTRY)
+12 IF TYPE="ICD0("
SET X=$$VLT^ICDEX(80.1,+ENTRY)
+13 QUIT X
+14 ;
INPUT() ; - Input transform for 27.27;9 S X=$$INPUT^DGPTIC10() K:X<1 X
+1 NEW ICDVER,CAT
+2 SET CAT=$PIECE(^(0),U,2)
SET Y(0)=$SELECT(CAT="D":80,CAT-"P":80.1,1:"")
+3 SET ICDVER=$SELECT(CAT="D":"10D",1:"10P")
+4 DO ^DIC
KILL DIC
SET DIC=DIE
SET X=+Y
if Y<0
KILL X
+5 QUIT X
DATERANG ; Get an ICD-10 compliant date range
+1 ;
NEW IMPDATE,DGSDATE
+2 SET IMPDATE=+$$IMPDATE^DGPTIC10("10D")
+3 WRITE !!,"ICD-10 Implementation Date: ",$$FMTE^XLFDT(IMPDATE),!
+4 SET DGSDATE=$$SDAT()
if DGSDATE<1
GOTO DRQ
+5 SET DGEDATE=$$TDAT(DGSDATE)
+6 ;G:EDATE<1 DRQ
DRQ ;
+1 ;
SDAT() ; ask for start date
+1 NEW Y,DIR,DTOUT,DUOUT
+2 SET DIR(0)="D^:"_DT_":EX"
SET DIR("A")="Start Date"
+3 DO ^DIR
KILL DIR
+4 if $DATA(DTOUT)!($DATA(DUOUT))
QUIT -1
+5 QUIT Y
TDAT(DGSDAT) ; ask for end date
+1 NEW Y,DIR,DTOUT,DUOUT
+2 SET DIR(0)="D^"_DGSDAT_":"_DT_":EX"
SET DIR("A")="End Date"
+3 IF '$DATA(IMPDATE)
SET IMPDATE=+$$IMPDATE^DGPTIC10("10D")
+4 IF DGSDAT<IMPDATE
IF DT'<IMPDATE
Begin DoDot:1
+5 WRITE !!,?10,"Start date is before ICD-10 implementation.",!,?10,"End date must be before ICD-10 implementation",!
+6 SET DIR(0)="D^"_DGSDAT_":"_$$FMADD^XLFDT(IMPDATE,-1)_":EX"
End DoDot:1
+7 DO ^DIR
KILL DIR
+8 if $DATA(DTOUT)!($DATA(DUOUT))
QUIT -1
+9 QUIT Y
+10 ;
CENSUS(DGPTF) ; display warning to user for ICD-10 transition census records
+1 ;this census subroutine call displaying a warning message is disabled
+2 ;and is not used for the icd-10 implementation period.
+3 ; -- do not remove this procedure from the routine
+4 ; -- called by input templates DG401, DG501, DG501F, DG601, and DG701
+5 ;
+6 ;
+7 QUIT
+8 NEW X,Y,CENDATE,EFFDATE,IMPDATE,DGPTDAT
+9 ;
+10 ; -- Called directly from fileman, no variable set up.
if '$DATA(PTF)
QUIT
+11 ;
+12 ; -- Get census status (DGCST) and ien of census date (DGCN)
+13 NEW DGSAVE
SET DGSAVE=$GET(DGPTF0)
DO CEN^DGPTC1
SET DGPTF0=DGSAVE
+14 ;
+15 IF '$DATA(DGCST)
GOTO CENSUSQ
+16 ; status no longer open
IF $GET(DGCST)>0
GOTO CENSUSQ
+17 ;
+18 ; -- DGCST=Census Status, dgcn=ien of census date file
+19 IF $DATA(DGCST)
IF DGCST=0
IF DGCN>0
SET CENDATE=$PIECE($GET(^DG(45.86,DGCN,0)),U,1)
+20 DO EFFDATE(DGPTF)
+21 IF CENDATE<IMPDATE
IF DT'<IMPDATE
Begin DoDot:1
+22 WRITE !!,?5,"Note: This PTF record is OPEN for CENSUS."
+23 WRITE !,?7,"Census requires ICD-9 codes."
+24 WRITE !,?7,"PTF will require ICD-10 codes after the census is closed.",!
End DoDot:1
CENSUSQ ;
+1 QUIT
+2 ;
