- DGPTFIC ;ALB/JDS/ADL,HIOFO/FT - PTF CODE SEARCH ;4/21/2015 4:14pm
- ;;5.3;Registration;**510,559,599,669,704,744,832,850,884,1063**;Aug 13, 1993;Build 7
- ;;ADL;;Update for CSV Project;;Mar 25, 2003
- ;
- ; LEXU APIs - #5679
- ; ICDEX APISs - #5747
- ; ICDSAPI APIs - #5757
- ; ICDXCODE APIs - #5699
- ;
- ;;Patch DG*5.3*832 notations are for additional checks to insure the
- ;; search includes looking at secondary diagnostic
- ;; codes 10-13, in node ^DGPT(ien,71)
- EN ;Diagnostic Code PTF Record Search [DG PTF ICD DIAGNOSTIC SEARCH]
- K DG1 S DIC="^ICD9("
- D CODESET^DGPTEXPR Q:CODESET<1
- G RANGE
- E9 K DIC S DHD=DHD_" Diagnostic Code Search"
- ;
- F9 ; search ^DGPT for the DX codes
- S DIS(0)="I $D(^DGPT(D0,0)),$P(^(0),U,11)=1 S DG2=0,L=1,D1=+$O(^DGPT(D0,""M"",0)) X DIS(""0AAA""),DIS(""0A"") I DG2 S ^UTILITY($J,""DG"",0)=""D""" ;;DG*832
- S DIS("0A")="F E=0:0 X DIS(""0AA"") S D1=$O(^DGPT(D0,""M"",D1)) Q:D1'>0"
- S DG9=$S('DGR:"I DG1[(U_DGIEN_U)",1:"D EFFDATE^DGPTIC10(D0) S DG=$$ICDDATA^ICDXCODE(""DIAG"",+DGIEN,EFFDATE) I $P(DG,U,20)=DGTERMIE S DG4=$S(+DG>0&($P(DG,U,10)):$P(DG,U,2),1:"""")_""!"" I DG4]DG1&(DG6]DG4)")
- S XAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U_DG3DT_U_DGIEN"
- S DIS("0AA")="I $D(^DGPT(D0,""M"",D1,0)) D 501^DGPTFIC F DGZD=1:1:25 S DGIEN=$P(DG3,U,DGZD) "_DG9_" X XAA"
- S XAAA="D EFFDATE^DGPTIC10(D0) S DG2=DG2+1,$P(^UTILITY($J,""DG"",D0,""A""),U,DGZD)=$$CODEC^ICDEX(80,+DGIEN)"
- S DIS("0AAA")="I $D(^DGPT(D0,70)) D 701^DGPTFIC F DGZD=1:1:25 S DGIEN=$P(DG3,U,DGZD) "_DG9_" X XAAA"
- S L=0
- ;
- GO ;
- K DG9 W !,"Searching the PTF file Select fields to sort by",! S DIC="^DGPT(",L=0
- S FLDS=$S($G(CODESET)=9:"[DGICD-9]",$G(CODESET)=10:"[DGICD-10]",1:"[DGICD]") D EN1^DIP
- Q ; kill variables
- K DIS,DGZD,DGZJ,DINS,DXS,DTOUT,DG4,DGR,DIP,DP,%,DGZJJ,DGZT,DG1,DHD,I,J,DG2,DG3,DG3DT,DG5,DG6,DG7,DG8,DG9,D0,DJ,DTOT,FLDS,L,PROMPT,Z,X,DIC,X1,Y,XAA,XAAA,XAAAA
- K CODESET,DGDAT,DGPTDAT,DGTERM,DGTERMIE,DGVDT,LEXQ,LEXVDT,EFFDATE,IMPDATE,DG,DGIEN
- Q
- ;
- EN1 ;Surgical Code PTF Record Search [DG PTF ICD SURGICAL SEARCH]
- S DIC="^ICD0("
- D CODESET^DGPTEXPR Q:CODESET<1
- G RANGE
- E0 K DIC S DHD=DHD_" Surgical Code Search"
- F0 ; search ^DGPT for the procedure codes
- S DIS(0)="I $D(^DGPT(D0,0)),$P(^(0),U,11)=1 S DG2=0,L=1 X:$D(^DGPT(D0,""P"")) DIS(""0AAAA"") S D1=+$O(^DGPT(D0,""S"",0)) X DIS(""0AAA"") X DIS(""0A"") I DG2 S ^UTILITY($J,""DG"",0)=""P"""
- S DIS("0A")="F E=0:0 X DIS(""0AA"") S D1=$O(^DGPT(D0,""S"",D1)) Q:D1'>0"
- S DG9=$S('DGR:"I DG1[(U_+DGIEN_U)",1:"D EFFDATE^DGPTIC10(D0) S DG=$$ICDDATA^ICDXCODE(""PROC"",+DGIEN,EFFDATE) I $P(DG,U,15)=DGTERMIE S DG4=$S(+DG>0&($P(DG,U,10)):$P(DG,U,2),1:"""")_""!"" I DG4]DG1&(DG6]DG4)")
- S XAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U_DG3DT_U_DGIEN"
- S DIS("0AA")="I $D(^DGPT(D0,""S"",D1,0)) D 401^DGPTFIC F DGZD=1:1:25 S DGIEN=$P(DG3,U,DGZD) "_DG9_" X XAA"
- S XAAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U_U_DGIEN"
- S DIS("0AAA")="I $D(^DGPT(D0,""401P"")) S DG3=^(""401P"") F DGZD=1:1:5 S DGIEN=$P(DG3,U,DGZD) "_DG9_" X XAAA"
- S XAAAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U_DG3DT_U_DGIEN"
- S DIS("0AAAA")="F D1=0:0 S D1=$O(^DGPT(D0,""P"",D1)) Q:D1'>0 I $D(^DGPT(D0,""P"",D1,0)) D 601^DGPTFIC F DGZD=1:1:25 S DGIEN=$P(DG3,U,DGZD) "_DG9_" X XAAAA"
- S L=0
- G GO
- Q
- OUT ; -- Output called from Print templates DGICD and DGICD-10
- S DGZJ=$X,DG2=$S(DGZT["ICD":"^ICD9(",1:"^ICD0("),DIO=1
- F I=0:0 S I=$O(^UTILITY($J,"DG",D0,I)) Q:I'>0 D
- . S J=^(I),Y=$P($P(J,U,2),".",1) X ^DD("DD") ;^(I) references global in line above
- . W:I>1 !?DGZJ W DGZT_$P(J,U,1)_" "_Y
- . W ?DGZJ+23,$P(@(DG2_"$P(J,U,3)"_",0)"),U,1)
- . I DG5 S DJ=$S($D(DJ):DJ,1:0)+1,DTOT=1
- ;
- Q:'$D(^UTILITY($J,"DG",D0,"A")) S J=^("A")
- F I=1:1:25 S K=$P(J,U,I) I K]"" W !?DGZJ,$S(I=1:"PRINCIPAL DIAGNOSIS",1:"SECONDARY DIAG "_I),?DGZJ+23,K I DG5 S DJ=$S($D(DJ):DJ,1:0)+1,DTOT=1
- Q
- HDRR ;
- N HDR,OLDHDR
- S OLDHDR="FOUND______DATE________CODE" ;L30
- I CODESYS=9 S HDR="FOUND______DATE________ICD-9 CODE"
- I CODESYS=10 S HDR="FOUND______DATE________ICD-10 CODE"
- ;
- DHD S PROMPT="Then search for: ",DIC("S")=$S($G(DIC("S"))="":"I DG1'[(U_+Y_U)",1:DIC("S")_"&(DG1'[(U_+Y_U))")
- F I=0:0 D Q:Y<1 S DG1=DG1_+Y_U Q:$L(DG1)>235
- . S Y=$$ICDLOOK(DGTERM,DGVDT,DIC("A")) Q:Y<1 S DG1=DG1_+Y_U Q:$L(DG1)>235
- S DHD="" F I=2:1 S DHD=DHD_$S(I'=2:", ",1:"")_$P(@(DIC_"$P(DG1,U,I)"_",0)"),U,1) Q:'$P(DG1,U,I+1) I $L(DHD)>200 S DHD=DHD_"....." Q
- ;
- C W !,"Total by PTF record or ICD count: P// " S Z="^PTF record^ICD count" R X:DTIME G Q:X=U!'$T X:X="" "S X=""P"" W X" D IN^DGHELP G H:%=-1 S DG5=$S(X="I":1,1:0) Q
- ;
- H W !!,"The search may have more than 1 match per PTF record",!,"Type 'P' to total only PTF records",!,"Type 'I' to total all matches",! G C
- H1 W !!,"Type 'R' to specify a range of codes",!," 'E' to specify a series of codes to match exactly",!
- ;
- RANGE ;
- S DIC(0)="AMEQZ" K LEXVDT
- S DGTERM=$S(DIC[9&(CODESET=9):"ICD",DIC[9&(CODESET=10):"10D",DIC[0&(CODESET=9):"ICP",DIC[0&(CODESET=10):"10P",1:"")
- S DGTERMIE=$S(DIC[9&(CODESET=9):1,DIC[9&(CODESET=10):30,DIC[0&(CODESET=9):2,DIC[0&(CODESET=10):31,1:"")
- S DGVDT=$$IMPDATE^LEXU("10D")
- I CODESET=9 S DGVDT=DGVDT-30000
- I CODESET=10 S DGVDT=$S(DT>DGVDT:DT,1:DGVDT+3) ;DG*5.3*1063 Setting DGVDT to DT to find ICD10 codes activated after 10/01/2015
- W !,"Search by Range or Exact match: E// "
- S Z="^RANGE^EXACT MATCH" R X:DTIME
- G Q:X=U!'$T X:X="" "S X=""E"" W X" D IN^DGHELP G H1:%=-1 S DGR=$S(X="R":1,1:0)
- S DG7=$S(DIC[9:"Diagnosis",1:"Surgical") G E:'DGR
- S DIC("A")="Start with "_DG7_" code: "
- S Y=$$ICDLOOK(DGTERM,DGVDT,DIC("A")) G Q:Y'>0 S DG1=$P(Y,U,2)_" "
- F ;
- S DIC("A")="Go to "_DG7_" code: " S Y=$$ICDLOOK(DGTERM,DGVDT,DIC("A")) G Q:+Y<1
- S DG6=$P(Y,U,2)_"! " I DG6']DG1 W !,"Must be after start code",! G F
- S DHD=DG1_" to "_$P(DG6,"!",1)_" "_DG7_" Code Search" D C G Q:'$D(X),@("F"_$E(DIC,5))
- Q
- ;
- E ;
- S DIC("A")="Select "_DG7_" code: "
- S Y=$$ICDLOOK(DGTERM,DGVDT,DIC("A"))
- G Q:Y'>0 S DG1=U_+Y_U D DHD G Q:'$D(X),@("E"_$E(DIC,5))
- Q
- ICDLOOK(TERM,EFFDATE,PROMPT) ; icd lookup
- ; called from DGPTFIC and DGPTDRG
- K X,Y,LEXVDT
- N DIC,DGDAT ;,EFFDATE,IMPDATE,TERM,DGTEMP
- S DGDAT=$S(EFFDATE'="":EFFDATE,1:DT)
- I TERM="10D"!(TERM="ICD") D DIAG
- I TERM="10P"!(TERM="ICP") D PROC
- Q $G(Y)
- ;
- DIAG ; Ask diagnosis
- N DGSAV,DIR
- ;
- I $G(PROMPT)'="" S DIR("A")=PROMPT
- ;1/16/2014 String must be at least 3 chars and up to 30 chars,
- ;but API's truncate, so no need to reject over 30. ICD-9 has no listed upper boundary
- ;lower boundary needs to be 1 to allow for "?"
- I CODESET=10 S DIR(0)="FAO^1:",DIR("?")="^D D1^DGICDGT",DIR("??")="^D D2^DGICDGT"
- I CODESET=9 S DIR(0)="FAO^1:",DIR("?")="^D D19^DGICDGT",DIR("??")="^D D29^DGICDGT"
- D ^DIR
- S DGSAV=$G(Y)
- I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))!(Y="") S Y=-1 Q
- I CODESET=9 D ICDEN1^DGPTF5 ;maintain legacy search
- I CODESET=10 D LEX^DGICD
- I ($D(DUOUT))!($D(DIRUT)),DGSAV=$G(Y) G DIAG ;User entered an "^" during the search - start over.
- I $G(X)="",$G(Y)'=-1,$L($G(Y))=1,$L($G(DGSAV))=1 G DIAG ; If 1 character answer, repeat request
- I '$D(X),'$D(Y) G DIAG ;Invalid ICD-10 entry
- I $G(Y)<1,$G(X)=DGSAV G DIAG ; Invalid ICD-9 entry
- I $G(Y)>0 S X=+Y,Y=$$ICDDATA^ICDXCODE("DIAG",$G(X),EFFDATE)
- Q
- ;
- PROC ; Ask Procedure
- N DGSAV,DIR,IMPDATE
- S IMPDATE=$$IMPDATE^LEXU(31)
- I $G(CODESET)="" S CODESET=$S(DT<$G(IMPDATE):9,1:10)
- I '$D(EFFDATE) S EFFDATE=$S(CODESET=10:IMPDATE+1,1:IMPDATE-1)
- ;
- S DIR(0)="FAO^1:12"
- I $G(PROMPT)'="" S DIR("A")=PROMPT
- I $G(CODESET)=10 S DIR("?")="^D P1^DGICDGT",DIR("??")="^D P2^DGICDGT"
- I $G(CODESET)=9 S DIR("?")="^D P19^DGICDGT",%=0
- D ^DIR
- S DGSAV=$G(Y)
- I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))!(Y="") S Y=-1 Q
- I CODESET=9 S Y=$$SEARCH^ICDSAPI("PROC",,"QEMZ",EFFDATE) D
- . I +$G(DGSAV)>0,$G(Y)<1,'+$G(X) K X,Y ; Original Search value was valid but ICDSAPI returned -1
- . Q
- I CODESET=10 D
- . I X["*" S X=$P(X,"*",1)_$P(X,"*",2)
- . D ASK^DGICP
- ;
- I '$D(X),'$D(Y) G PROC ;Invalid ICD entry
- I $G(Y)<1,$G(X)=DGSAV G PROC ; Invalid ICD-9 entry
- I $G(Y)>0 S X=+Y,Y=$$ICDDATA^ICDXCODE("PROC",$G(X),EFFDATE)
- K LEXVDT
- Q Y
- ;
- 401 ; Build 25 piece string with OPERATION codes
- N DG401
- S DG401=$G(^DGPT(D0,"S",D1,0)),DG3=$$STR401^DGPTFUT(D0,D1),DG3DT=$P(DG401,U,1)
- Q
- 501 ; Build 25 piece string with MOVEMENT codes
- N DG501
- S DG501=$G(^DGPT(D0,"M",D1,0)),DG3=$$STR501^DGPTFUT(D0,D1),DG3DT=$P(DG501,U,10)
- Q
- 601 ; Build 25 piece string with PROCEDURE codes
- N DG601
- S DG601=$G(^DGPT(D0,"P",D1,0)),DG3=$$STR601^DGPTFUT(D0,D1),DG3DT=$P(DG601,U,1)
- Q
- 701 ; Build 25 piece string with DIAGNOSTIC codes
- S DG3=$$STR701^DGPTFUT(D0)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFIC 8740 printed Feb 19, 2025@00:18:14 Page 2
- DGPTFIC ;ALB/JDS/ADL,HIOFO/FT - PTF CODE SEARCH ;4/21/2015 4:14pm
- +1 ;;5.3;Registration;**510,559,599,669,704,744,832,850,884,1063**;Aug 13, 1993;Build 7
- +2 ;;ADL;;Update for CSV Project;;Mar 25, 2003
- +3 ;
- +4 ; LEXU APIs - #5679
- +5 ; ICDEX APISs - #5747
- +6 ; ICDSAPI APIs - #5757
- +7 ; ICDXCODE APIs - #5699
- +8 ;
- +9 ;;Patch DG*5.3*832 notations are for additional checks to insure the
- +10 ;; search includes looking at secondary diagnostic
- +11 ;; codes 10-13, in node ^DGPT(ien,71)
- EN ;Diagnostic Code PTF Record Search [DG PTF ICD DIAGNOSTIC SEARCH]
- +1 KILL DG1
- SET DIC="^ICD9("
- +2 DO CODESET^DGPTEXPR
- if CODESET<1
- QUIT
- +3 GOTO RANGE
- E9 KILL DIC
- SET DHD=DHD_" Diagnostic Code Search"
- +1 ;
- F9 ; search ^DGPT for the DX codes
- +1 ;;DG*832
- SET DIS(0)="I $D(^DGPT(D0,0)),$P(^(0),U,11)=1 S DG2=0,L=1,D1=+$O(^DGPT(D0,""M"",0)) X DIS(""0AAA""),DIS(""0A"") I DG2 S ^UTILITY($J,""DG"",0)=""D"""
- +2 SET DIS("0A")="F E=0:0 X DIS(""0AA"") S D1=$O(^DGPT(D0,""M"",D1)) Q:D1'>0"
- +3 SET DG9=$SELECT('DGR:"I DG1[(U_DGIEN_U)",1:"D EFFDATE^DGPTIC10(D0) S DG=$$ICDDATA^ICDXCODE(""DIAG"",+DGIEN,EFFDATE) I $P(DG,U,20)=DGTERMIE S DG4=$S(+DG>0&($P(DG,U,10)):$P(DG,U,2),1:"""")_""!"" I DG4]DG1&(DG6]DG4)")
- +4 SET XAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U_DG3DT_U_DGIEN"
- +5 SET DIS("0AA")="I $D(^DGPT(D0,""M"",D1,0)) D 501^DGPTFIC F DGZD=1:1:25 S DGIEN=$P(DG3,U,DGZD) "_DG9_" X XAA"
- +6 SET XAAA="D EFFDATE^DGPTIC10(D0) S DG2=DG2+1,$P(^UTILITY($J,""DG"",D0,""A""),U,DGZD)=$$CODEC^ICDEX(80,+DGIEN)"
- +7 SET DIS("0AAA")="I $D(^DGPT(D0,70)) D 701^DGPTFIC F DGZD=1:1:25 S DGIEN=$P(DG3,U,DGZD) "_DG9_" X XAAA"
- +8 SET L=0
- +9 ;
- GO ;
- +1 KILL DG9
- WRITE !,"Searching the PTF file Select fields to sort by",!
- SET DIC="^DGPT("
- SET L=0
- +2 SET FLDS=$SELECT($GET(CODESET)=9:"[DGICD-9]",$GET(CODESET)=10:"[DGICD-10]",1:"[DGICD]")
- DO EN1^DIP
- Q ; kill variables
- +1 KILL DIS,DGZD,DGZJ,DINS,DXS,DTOUT,DG4,DGR,DIP,DP,%,DGZJJ,DGZT,DG1,DHD,I,J,DG2,DG3,DG3DT,DG5,DG6,DG7,DG8,DG9,D0,DJ,DTOT,FLDS,L,PROMPT,Z,X,DIC,X1,Y,XAA,XAAA,XAAAA
- +2 KILL CODESET,DGDAT,DGPTDAT,DGTERM,DGTERMIE,DGVDT,LEXQ,LEXVDT,EFFDATE,IMPDATE,DG,DGIEN
- +3 QUIT
- +4 ;
- EN1 ;Surgical Code PTF Record Search [DG PTF ICD SURGICAL SEARCH]
- +1 SET DIC="^ICD0("
- +2 DO CODESET^DGPTEXPR
- if CODESET<1
- QUIT
- +3 GOTO RANGE
- E0 KILL DIC
- SET DHD=DHD_" Surgical Code Search"
- F0 ; search ^DGPT for the procedure codes
- +1 SET DIS(0)="I $D(^DGPT(D0,0)),$P(^(0),U,11)=1 S DG2=0,L=1 X:$D(^DGPT(D0,""P"")) DIS(""0AAAA"") S D1=+$O(^DGPT(D0,""S"",0)) X DIS(""0AAA"") X DIS(""0A"") I DG2 S ^UTILITY($J,""DG"",0)=""P"""
- +2 SET DIS("0A")="F E=0:0 X DIS(""0AA"") S D1=$O(^DGPT(D0,""S"",D1)) Q:D1'>0"
- +3 SET DG9=$SELECT('DGR:"I DG1[(U_+DGIEN_U)",1:"D EFFDATE^DGPTIC10(D0) S DG=$$ICDDATA^ICDXCODE(""PROC"",+DGIEN,EFFDATE) I $P(DG,U,15)=DGTERMIE S DG4=$S(+DG>0&($P(DG,U,10)):$P(DG,U,2),1:"""")_""!"" I DG4]DG1&(DG6]DG4)")
- +4 SET XAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U_DG3DT_U_DGIEN"
- +5 SET DIS("0AA")="I $D(^DGPT(D0,""S"",D1,0)) D 401^DGPTFIC F DGZD=1:1:25 S DGIEN=$P(DG3,U,DGZD) "_DG9_" X XAA"
- +6 SET XAAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U_U_DGIEN"
- +7 SET DIS("0AAA")="I $D(^DGPT(D0,""401P"")) S DG3=^(""401P"") F DGZD=1:1:5 S DGIEN=$P(DG3,U,DGZD) "_DG9_" X XAAA"
- +8 SET XAAAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U_DG3DT_U_DGIEN"
- +9 SET DIS("0AAAA")="F D1=0:0 S D1=$O(^DGPT(D0,""P"",D1)) Q:D1'>0 I $D(^DGPT(D0,""P"",D1,0)) D 601^DGPTFIC F DGZD=1:1:25 S DGIEN=$P(DG3,U,DGZD) "_DG9_" X XAAAA"
- +10 SET L=0
- +11 GOTO GO
- +12 QUIT
- OUT ; -- Output called from Print templates DGICD and DGICD-10
- +1 SET DGZJ=$X
- SET DG2=$SELECT(DGZT["ICD":"^ICD9(",1:"^ICD0(")
- SET DIO=1
- +2 FOR I=0:0
- SET I=$ORDER(^UTILITY($JOB,"DG",D0,I))
- if I'>0
- QUIT
- Begin DoDot:1
- +3 ;^(I) references global in line above
- SET J=^(I)
- SET Y=$PIECE($PIECE(J,U,2),".",1)
- XECUTE ^DD("DD")
- +4 if I>1
- WRITE !?DGZJ
- WRITE DGZT_$PIECE(J,U,1)_" "_Y
- +5 WRITE ?DGZJ+23,$PIECE(@(DG2_"$P(J,U,3)"_",0)"),U,1)
- +6 IF DG5
- SET DJ=$SELECT($DATA(DJ):DJ,1:0)+1
- SET DTOT=1
- End DoDot:1
- +7 ;
- +8 if '$DATA(^UTILITY($JOB,"DG",D0,"A"))
- QUIT
- SET J=^("A")
- +9 FOR I=1:1:25
- SET K=$PIECE(J,U,I)
- IF K]""
- WRITE !?DGZJ,$SELECT(I=1:"PRINCIPAL DIAGNOSIS",1:"SECONDARY DIAG "_I),?DGZJ+23,K
- IF DG5
- SET DJ=$SELECT($DATA(DJ):DJ,1:0)+1
- SET DTOT=1
- +10 QUIT
- HDRR ;
- +1 NEW HDR,OLDHDR
- +2 ;L30
- SET OLDHDR="FOUND______DATE________CODE"
- +3 IF CODESYS=9
- SET HDR="FOUND______DATE________ICD-9 CODE"
- +4 IF CODESYS=10
- SET HDR="FOUND______DATE________ICD-10 CODE"
- +5 ;
- DHD SET PROMPT="Then search for: "
- SET DIC("S")=$SELECT($GET(DIC("S"))="":"I DG1'[(U_+Y_U)",1:DIC("S")_"&(DG1'[(U_+Y_U))")
- +1 FOR I=0:0
- Begin DoDot:1
- +2 SET Y=$$ICDLOOK(DGTERM,DGVDT,DIC("A"))
- if Y<1
- QUIT
- SET DG1=DG1_+Y_U
- if $LENGTH(DG1)>235
- QUIT
- End DoDot:1
- if Y<1
- QUIT
- SET DG1=DG1_+Y_U
- if $LENGTH(DG1)>235
- QUIT
- +3 SET DHD=""
- FOR I=2:1
- SET DHD=DHD_$SELECT(I'=2:", ",1:"")_$PIECE(@(DIC_"$P(DG1,U,I)"_",0)"),U,1)
- if '$PIECE(DG1,U,I+1)
- QUIT
- IF $LENGTH(DHD)>200
- SET DHD=DHD_"....."
- QUIT
- +4 ;
- C WRITE !,"Total by PTF record or ICD count: P// "
- SET Z="^PTF record^ICD count"
- READ X:DTIME
- if X=U!'$TEST
- GOTO Q
- if X=""
- XECUTE "S X=""P"" W X"
- DO IN^DGHELP
- if %=-1
- GOTO H
- SET DG5=$SELECT(X="I":1,1:0)
- QUIT
- +1 ;
- H WRITE !!,"The search may have more than 1 match per PTF record",!,"Type 'P' to total only PTF records",!,"Type 'I' to total all matches",!
- GOTO C
- H1 WRITE !!,"Type 'R' to specify a range of codes",!," 'E' to specify a series of codes to match exactly",!
- +1 ;
- RANGE ;
- +1 SET DIC(0)="AMEQZ"
- KILL LEXVDT
- +2 SET DGTERM=$SELECT(DIC[9&(CODESET=9):"ICD",DIC[9&(CODESET=10):"10D",DIC[0&(CODESET=9):"ICP",DIC[0&(CODESET=10):"10P",1:"")
- +3 SET DGTERMIE=$SELECT(DIC[9&(CODESET=9):1,DIC[9&(CODESET=10):30,DIC[0&(CODESET=9):2,DIC[0&(CODESET=10):31,1:"")
- +4 SET DGVDT=$$IMPDATE^LEXU("10D")
- +5 IF CODESET=9
- SET DGVDT=DGVDT-30000
- +6 ;DG*5.3*1063 Setting DGVDT to DT to find ICD10 codes activated after 10/01/2015
- IF CODESET=10
- SET DGVDT=$SELECT(DT>DGVDT:DT,1:DGVDT+3)
- +7 WRITE !,"Search by Range or Exact match: E// "
- +8 SET Z="^RANGE^EXACT MATCH"
- READ X:DTIME
- +9 if X=U!'$TEST
- GOTO Q
- if X=""
- XECUTE "S X=""E"" W X"
- DO IN^DGHELP
- if %=-1
- GOTO H1
- SET DGR=$SELECT(X="R":1,1:0)
- +10 SET DG7=$SELECT(DIC[9:"Diagnosis",1:"Surgical")
- if 'DGR
- GOTO E
- +11 SET DIC("A")="Start with "_DG7_" code: "
- +12 SET Y=$$ICDLOOK(DGTERM,DGVDT,DIC("A"))
- if Y'>0
- GOTO Q
- SET DG1=$PIECE(Y,U,2)_" "
- F ;
- +1 SET DIC("A")="Go to "_DG7_" code: "
- SET Y=$$ICDLOOK(DGTERM,DGVDT,DIC("A"))
- if +Y<1
- GOTO Q
- +2 SET DG6=$PIECE(Y,U,2)_"! "
- IF DG6']DG1
- WRITE !,"Must be after start code",!
- GOTO F
- +3 SET DHD=DG1_" to "_$PIECE(DG6,"!",1)_" "_DG7_" Code Search"
- DO C
- if '$DATA(X)
- GOTO Q
- GOTO @("F"_$EXTRACT(DIC,5))
- +4 QUIT
- +5 ;
- E ;
- +1 SET DIC("A")="Select "_DG7_" code: "
- +2 SET Y=$$ICDLOOK(DGTERM,DGVDT,DIC("A"))
- +3 if Y'>0
- GOTO Q
- SET DG1=U_+Y_U
- DO DHD
- if '$DATA(X)
- GOTO Q
- GOTO @("E"_$EXTRACT(DIC,5))
- +4 QUIT
- ICDLOOK(TERM,EFFDATE,PROMPT) ; icd lookup
- +1 ; called from DGPTFIC and DGPTDRG
- +2 KILL X,Y,LEXVDT
- +3 ;,EFFDATE,IMPDATE,TERM,DGTEMP
- NEW DIC,DGDAT
- +4 SET DGDAT=$SELECT(EFFDATE'="":EFFDATE,1:DT)
- +5 IF TERM="10D"!(TERM="ICD")
- DO DIAG
- +6 IF TERM="10P"!(TERM="ICP")
- DO PROC
- +7 QUIT $GET(Y)
- +8 ;
- DIAG ; Ask diagnosis
- +1 NEW DGSAV,DIR
- +2 ;
- +3 IF $GET(PROMPT)'=""
- SET DIR("A")=PROMPT
- +4 ;1/16/2014 String must be at least 3 chars and up to 30 chars,
- +5 ;but API's truncate, so no need to reject over 30. ICD-9 has no listed upper boundary
- +6 ;lower boundary needs to be 1 to allow for "?"
- +7 IF CODESET=10
- SET DIR(0)="FAO^1:"
- SET DIR("?")="^D D1^DGICDGT"
- SET DIR("??")="^D D2^DGICDGT"
- +8 IF CODESET=9
- SET DIR(0)="FAO^1:"
- SET DIR("?")="^D D19^DGICDGT"
- SET DIR("??")="^D D29^DGICDGT"
- +9 DO ^DIR
- +10 SET DGSAV=$GET(Y)
- +11 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))!(Y="")
- SET Y=-1
- QUIT
- +12 ;maintain legacy search
- IF CODESET=9
- DO ICDEN1^DGPTF5
- +13 IF CODESET=10
- DO LEX^DGICD
- +14 ;User entered an "^" during the search - start over.
- IF ($DATA(DUOUT))!($DATA(DIRUT))
- IF DGSAV=$GET(Y)
- GOTO DIAG
- +15 ; If 1 character answer, repeat request
- IF $GET(X)=""
- IF $GET(Y)'=-1
- IF $LENGTH($GET(Y))=1
- IF $LENGTH($GET(DGSAV))=1
- GOTO DIAG
- +16 ;Invalid ICD-10 entry
- IF '$DATA(X)
- IF '$DATA(Y)
- GOTO DIAG
- +17 ; Invalid ICD-9 entry
- IF $GET(Y)<1
- IF $GET(X)=DGSAV
- GOTO DIAG
- +18 IF $GET(Y)>0
- SET X=+Y
- SET Y=$$ICDDATA^ICDXCODE("DIAG",$GET(X),EFFDATE)
- +19 QUIT
- +20 ;
- PROC ; Ask Procedure
- +1 NEW DGSAV,DIR,IMPDATE
- +2 SET IMPDATE=$$IMPDATE^LEXU(31)
- +3 IF $GET(CODESET)=""
- SET CODESET=$SELECT(DT<$GET(IMPDATE):9,1:10)
- +4 IF '$DATA(EFFDATE)
- SET EFFDATE=$SELECT(CODESET=10:IMPDATE+1,1:IMPDATE-1)
- +5 ;
- +6 SET DIR(0)="FAO^1:12"
- +7 IF $GET(PROMPT)'=""
- SET DIR("A")=PROMPT
- +8 IF $GET(CODESET)=10
- SET DIR("?")="^D P1^DGICDGT"
- SET DIR("??")="^D P2^DGICDGT"
- +9 IF $GET(CODESET)=9
- SET DIR("?")="^D P19^DGICDGT"
- SET %=0
- +10 DO ^DIR
- +11 SET DGSAV=$GET(Y)
- +12 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))!(Y="")
- SET Y=-1
- QUIT
- +13 IF CODESET=9
- SET Y=$$SEARCH^ICDSAPI("PROC",,"QEMZ",EFFDATE)
- Begin DoDot:1
- +14 ; Original Search value was valid but ICDSAPI returned -1
- IF +$GET(DGSAV)>0
- IF $GET(Y)<1
- IF '+$GET(X)
- KILL X,Y
- +15 QUIT
- End DoDot:1
- +16 IF CODESET=10
- Begin DoDot:1
- +17 IF X["*"
- SET X=$PIECE(X,"*",1)_$PIECE(X,"*",2)
- +18 DO ASK^DGICP
- End DoDot:1
- +19 ;
- +20 ;Invalid ICD entry
- IF '$DATA(X)
- IF '$DATA(Y)
- GOTO PROC
- +21 ; Invalid ICD-9 entry
- IF $GET(Y)<1
- IF $GET(X)=DGSAV
- GOTO PROC
- +22 IF $GET(Y)>0
- SET X=+Y
- SET Y=$$ICDDATA^ICDXCODE("PROC",$GET(X),EFFDATE)
- +23 KILL LEXVDT
- +24 QUIT Y
- +25 ;
- 401 ; Build 25 piece string with OPERATION codes
- +1 NEW DG401
- +2 SET DG401=$GET(^DGPT(D0,"S",D1,0))
- SET DG3=$$STR401^DGPTFUT(D0,D1)
- SET DG3DT=$PIECE(DG401,U,1)
- +3 QUIT
- 501 ; Build 25 piece string with MOVEMENT codes
- +1 NEW DG501
- +2 SET DG501=$GET(^DGPT(D0,"M",D1,0))
- SET DG3=$$STR501^DGPTFUT(D0,D1)
- SET DG3DT=$PIECE(DG501,U,10)
- +3 QUIT
- 601 ; Build 25 piece string with PROCEDURE codes
- +1 NEW DG601
- +2 SET DG601=$GET(^DGPT(D0,"P",D1,0))
- SET DG3=$$STR601^DGPTFUT(D0,D1)
- SET DG3DT=$PIECE(DG601,U,1)
- +3 QUIT
- 701 ; Build 25 piece string with DIAGNOSTIC codes
- +1 SET DG3=$$STR701^DGPTFUT(D0)
- +2 QUIT