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

DGPTFIC.m

Go to the documentation of this file.
  1. 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
  1. ;;ADL;;Update for CSV Project;;Mar 25, 2003
  1. ;
  1. ; LEXU APIs - #5679
  1. ; ICDEX APISs - #5747
  1. ; ICDSAPI APIs - #5757
  1. ; ICDXCODE APIs - #5699
  1. ;
  1. ;;Patch DG*5.3*832 notations are for additional checks to insure the
  1. ;; search includes looking at secondary diagnostic
  1. ;; codes 10-13, in node ^DGPT(ien,71)
  1. EN ;Diagnostic Code PTF Record Search [DG PTF ICD DIAGNOSTIC SEARCH]
  1. K DG1 S DIC="^ICD9("
  1. D CODESET^DGPTEXPR Q:CODESET<1
  1. G RANGE
  1. E9 K DIC S DHD=DHD_" Diagnostic Code Search"
  1. ;
  1. F9 ; search ^DGPT for the DX codes
  1. 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
  1. S DIS("0A")="F E=0:0 X DIS(""0AA"") S D1=$O(^DGPT(D0,""M"",D1)) Q:D1'>0"
  1. 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)")
  1. S XAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U_DG3DT_U_DGIEN"
  1. 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"
  1. S XAAA="D EFFDATE^DGPTIC10(D0) S DG2=DG2+1,$P(^UTILITY($J,""DG"",D0,""A""),U,DGZD)=$$CODEC^ICDEX(80,+DGIEN)"
  1. 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"
  1. S L=0
  1. ;
  1. GO ;
  1. K DG9 W !,"Searching the PTF file Select fields to sort by",! S DIC="^DGPT(",L=0
  1. S FLDS=$S($G(CODESET)=9:"[DGICD-9]",$G(CODESET)=10:"[DGICD-10]",1:"[DGICD]") D EN1^DIP
  1. Q ; kill variables
  1. 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
  1. K CODESET,DGDAT,DGPTDAT,DGTERM,DGTERMIE,DGVDT,LEXQ,LEXVDT,EFFDATE,IMPDATE,DG,DGIEN
  1. Q
  1. ;
  1. EN1 ;Surgical Code PTF Record Search [DG PTF ICD SURGICAL SEARCH]
  1. S DIC="^ICD0("
  1. D CODESET^DGPTEXPR Q:CODESET<1
  1. G RANGE
  1. E0 K DIC S DHD=DHD_" Surgical Code Search"
  1. F0 ; search ^DGPT for the procedure codes
  1. 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"""
  1. S DIS("0A")="F E=0:0 X DIS(""0AA"") S D1=$O(^DGPT(D0,""S"",D1)) Q:D1'>0"
  1. 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)")
  1. S XAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U_DG3DT_U_DGIEN"
  1. 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"
  1. S XAAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U_U_DGIEN"
  1. 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"
  1. S XAAAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U_DG3DT_U_DGIEN"
  1. 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"
  1. S L=0
  1. G GO
  1. Q
  1. OUT ; -- Output called from Print templates DGICD and DGICD-10
  1. S DGZJ=$X,DG2=$S(DGZT["ICD":"^ICD9(",1:"^ICD0("),DIO=1
  1. F I=0:0 S I=$O(^UTILITY($J,"DG",D0,I)) Q:I'>0 D
  1. . S J=^(I),Y=$P($P(J,U,2),".",1) X ^DD("DD") ;^(I) references global in line above
  1. . W:I>1 !?DGZJ W DGZT_$P(J,U,1)_" "_Y
  1. . W ?DGZJ+23,$P(@(DG2_"$P(J,U,3)"_",0)"),U,1)
  1. . I DG5 S DJ=$S($D(DJ):DJ,1:0)+1,DTOT=1
  1. ;
  1. Q:'$D(^UTILITY($J,"DG",D0,"A")) S J=^("A")
  1. 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
  1. Q
  1. HDRR ;
  1. N HDR,OLDHDR
  1. S OLDHDR="FOUND______DATE________CODE" ;L30
  1. I CODESYS=9 S HDR="FOUND______DATE________ICD-9 CODE"
  1. I CODESYS=10 S HDR="FOUND______DATE________ICD-10 CODE"
  1. ;
  1. DHD S PROMPT="Then search for: ",DIC("S")=$S($G(DIC("S"))="":"I DG1'[(U_+Y_U)",1:DIC("S")_"&(DG1'[(U_+Y_U))")
  1. F I=0:0 D Q:Y<1 S DG1=DG1_+Y_U Q:$L(DG1)>235
  1. . S Y=$$ICDLOOK(DGTERM,DGVDT,DIC("A")) Q:Y<1 S DG1=DG1_+Y_U Q:$L(DG1)>235
  1. 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
  1. ;
  1. 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
  1. ;
  1. 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
  1. H1 W !!,"Type 'R' to specify a range of codes",!," 'E' to specify a series of codes to match exactly",!
  1. ;
  1. RANGE ;
  1. S DIC(0)="AMEQZ" K LEXVDT
  1. S DGTERM=$S(DIC[9&(CODESET=9):"ICD",DIC[9&(CODESET=10):"10D",DIC[0&(CODESET=9):"ICP",DIC[0&(CODESET=10):"10P",1:"")
  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:"")
  1. S DGVDT=$$IMPDATE^LEXU("10D")
  1. I CODESET=9 S DGVDT=DGVDT-30000
  1. 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
  1. W !,"Search by Range or Exact match: E// "
  1. S Z="^RANGE^EXACT MATCH" R X:DTIME
  1. 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)
  1. S DG7=$S(DIC[9:"Diagnosis",1:"Surgical") G E:'DGR
  1. S DIC("A")="Start with "_DG7_" code: "
  1. S Y=$$ICDLOOK(DGTERM,DGVDT,DIC("A")) G Q:Y'>0 S DG1=$P(Y,U,2)_" "
  1. F ;
  1. S DIC("A")="Go to "_DG7_" code: " S Y=$$ICDLOOK(DGTERM,DGVDT,DIC("A")) G Q:+Y<1
  1. S DG6=$P(Y,U,2)_"! " I DG6']DG1 W !,"Must be after start code",! G F
  1. S DHD=DG1_" to "_$P(DG6,"!",1)_" "_DG7_" Code Search" D C G Q:'$D(X),@("F"_$E(DIC,5))
  1. Q
  1. ;
  1. E ;
  1. S DIC("A")="Select "_DG7_" code: "
  1. S Y=$$ICDLOOK(DGTERM,DGVDT,DIC("A"))
  1. G Q:Y'>0 S DG1=U_+Y_U D DHD G Q:'$D(X),@("E"_$E(DIC,5))
  1. Q
  1. ICDLOOK(TERM,EFFDATE,PROMPT) ; icd lookup
  1. ; called from DGPTFIC and DGPTDRG
  1. K X,Y,LEXVDT
  1. N DIC,DGDAT ;,EFFDATE,IMPDATE,TERM,DGTEMP
  1. S DGDAT=$S(EFFDATE'="":EFFDATE,1:DT)
  1. I TERM="10D"!(TERM="ICD") D DIAG
  1. I TERM="10P"!(TERM="ICP") D PROC
  1. Q $G(Y)
  1. ;
  1. DIAG ; Ask diagnosis
  1. N DGSAV,DIR
  1. ;
  1. I $G(PROMPT)'="" S DIR("A")=PROMPT
  1. ;1/16/2014 String must be at least 3 chars and up to 30 chars,
  1. ;but API's truncate, so no need to reject over 30. ICD-9 has no listed upper boundary
  1. ;lower boundary needs to be 1 to allow for "?"
  1. I CODESET=10 S DIR(0)="FAO^1:",DIR("?")="^D D1^DGICDGT",DIR("??")="^D D2^DGICDGT"
  1. I CODESET=9 S DIR(0)="FAO^1:",DIR("?")="^D D19^DGICDGT",DIR("??")="^D D29^DGICDGT"
  1. D ^DIR
  1. S DGSAV=$G(Y)
  1. I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))!(Y="") S Y=-1 Q
  1. I CODESET=9 D ICDEN1^DGPTF5 ;maintain legacy search
  1. I CODESET=10 D LEX^DGICD
  1. I ($D(DUOUT))!($D(DIRUT)),DGSAV=$G(Y) G DIAG ;User entered an "^" during the search - start over.
  1. I $G(X)="",$G(Y)'=-1,$L($G(Y))=1,$L($G(DGSAV))=1 G DIAG ; If 1 character answer, repeat request
  1. I '$D(X),'$D(Y) G DIAG ;Invalid ICD-10 entry
  1. I $G(Y)<1,$G(X)=DGSAV G DIAG ; Invalid ICD-9 entry
  1. I $G(Y)>0 S X=+Y,Y=$$ICDDATA^ICDXCODE("DIAG",$G(X),EFFDATE)
  1. Q
  1. ;
  1. PROC ; Ask Procedure
  1. N DGSAV,DIR,IMPDATE
  1. S IMPDATE=$$IMPDATE^LEXU(31)
  1. I $G(CODESET)="" S CODESET=$S(DT<$G(IMPDATE):9,1:10)
  1. I '$D(EFFDATE) S EFFDATE=$S(CODESET=10:IMPDATE+1,1:IMPDATE-1)
  1. ;
  1. S DIR(0)="FAO^1:12"
  1. I $G(PROMPT)'="" S DIR("A")=PROMPT
  1. I $G(CODESET)=10 S DIR("?")="^D P1^DGICDGT",DIR("??")="^D P2^DGICDGT"
  1. I $G(CODESET)=9 S DIR("?")="^D P19^DGICDGT",%=0
  1. D ^DIR
  1. S DGSAV=$G(Y)
  1. I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT))!(Y="") S Y=-1 Q
  1. I CODESET=9 S Y=$$SEARCH^ICDSAPI("PROC",,"QEMZ",EFFDATE) D
  1. . I +$G(DGSAV)>0,$G(Y)<1,'+$G(X) K X,Y ; Original Search value was valid but ICDSAPI returned -1
  1. . Q
  1. I CODESET=10 D
  1. . I X["*" S X=$P(X,"*",1)_$P(X,"*",2)
  1. . D ASK^DGICP
  1. ;
  1. I '$D(X),'$D(Y) G PROC ;Invalid ICD entry
  1. I $G(Y)<1,$G(X)=DGSAV G PROC ; Invalid ICD-9 entry
  1. I $G(Y)>0 S X=+Y,Y=$$ICDDATA^ICDXCODE("PROC",$G(X),EFFDATE)
  1. K LEXVDT
  1. Q Y
  1. ;
  1. 401 ; Build 25 piece string with OPERATION codes
  1. N DG401
  1. S DG401=$G(^DGPT(D0,"S",D1,0)),DG3=$$STR401^DGPTFUT(D0,D1),DG3DT=$P(DG401,U,1)
  1. Q
  1. 501 ; Build 25 piece string with MOVEMENT codes
  1. N DG501
  1. S DG501=$G(^DGPT(D0,"M",D1,0)),DG3=$$STR501^DGPTFUT(D0,D1),DG3DT=$P(DG501,U,10)
  1. Q
  1. 601 ; Build 25 piece string with PROCEDURE codes
  1. N DG601
  1. S DG601=$G(^DGPT(D0,"P",D1,0)),DG3=$$STR601^DGPTFUT(D0,D1),DG3DT=$P(DG601,U,1)
  1. Q
  1. 701 ; Build 25 piece string with DIAGNOSTIC codes
  1. S DG3=$$STR701^DGPTFUT(D0)
  1. Q