- DGPTFIC ;ALB/JDS/ADL - PTF CODE SEARCH ; 26 JAN 87 @0800 [7/12/04 2:53pm]
- ;;5.3;Registration;**510,559,599,669,704,744,1015**; Aug 13, 1993;Build 21
- ;;ADL;;Update for CSV Project;;Mar 25, 2003
- EN K DG1 S DIC="^ICD9(" ;;S DIC("S")="I $$ISVALID^ICDGTDRG(+Y,DGDAT,9)" G RANGE
- G RANGE
- E9 K DIC S DHD=DHD_" Diagnostic Code Search"
- F9 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""",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_$P(DG3,U,DGZD)_U)",1:"S DG=$$ICDDX^ICDCODE(+$P(DG3,U,DGZD),$$GETDATE^ICDGTDRG(D0)) 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)=$S(DGZD<11:DGZD-4,1:DGZD-5)_U_$P(DG3,U,10)_U_$P(DG3,U,DGZD)"
- S DIS("0AA")="I $D(^DGPT(D0,""M"",D1,0)) S DG3=^(0) F DGZD=5:1:15 "_DG9_" X XAA"
- S XAAA="S DG2=DG2+1,$P(^UTILITY($J,""DG"",D0,""A""),U,DGZD)=$P($$ICDDX^ICDCODE(+$P(DG3,U,DGZD),$$GETDATE^ICDGTDRG(D0)),U,2)"
- S DIS("0AAA")="I $D(^DGPT(D0,70)) S DG3=^(70) F DGZD=10,16:1:24 "_DG9_" X XAAA"
- S L=0
- GO K DG9 W !,"Searching the PTF file Select fields to sort by",! S DIC="^DGPT(",FLDS="[DGICD]",L=0 D EN1^DIP
- Q K DIS,DGZD,DGZJ,DINS,DXS,DTOUT,DG4,DGR,DIP,DP,%,DGZJJ,DGZT,DG1,DHD,I,J,DG2,DG3,DG5,DG6,DG7,DG8,DG9,D0,DJ,DTOT,FLDS,L,PROMPT,Z,X,DIC,X1,Y,XAA,XAAA,XAAAA Q
- EN1 ;
- S DIC="^ICD0(" ;;S DIC("S")="I $$ISVALID^ICDGTDRG(+Y,DGDAT,0)" G RANGE
- G RANGE
- E0 K DIC S DHD=DHD_" Surgical Code Search"
- F0 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_$P(DG3,U,DGZD)_U)",1:"S DG=$$ICDOP^ICDCODE(+$P(DG3,U,DGZD),$$GETDATE^ICDGTDRG(D0)) 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-7)_U_$P(DG3,U,1)_U_$P(DG3,U,DGZD)"
- S DIS("0AA")="I $D(^DGPT(D0,""S"",D1,0)) S DG3=^(0) F DGZD=8:1:12 "_DG9_" X XAA"
- S XAAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U_U_$P(DG3,U,DGZD)"
- S DIS("0AAA")="I $D(^DGPT(D0,""401P"")) S DG3=^(""401P"") F DGZD=1:1:5 "_DG9_" X XAAA"
- S XAAAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=(DGZD-4)_U_$P(DG3,U,1)_U_$P(DG3,U,DGZD)"
- S DIS("0AAAA")="F D1=0:0 S D1=$O(^DGPT(D0,""P"",D1)) Q:D1'>0 I $D(^DGPT(D0,""P"",D1,0)) S DG3=^(0) F DGZD=5:1:9 "_DG9_" X XAAAA"
- S L=0
- G GO
- Q
- OUT 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 S J=^(I),Y=$P($P(J,U,2),".",1) X ^DD("DD") 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=10,16:1:24 S K=$P(J,U,I) I K]"" W !?DGZJ,$S(I=10:"PRINCIPAL DIAGNOSIS",1:"ICD "_(I-14)),?DGZJ+23,K I DG5 S DJ=$S($D(DJ):DJ,1:0)+1,DTOT=1
- Q
- DHD S PROMPT="Then search for: ",DIC("S")=$S($G(DIC("S"))="":"I DG1'[(U_+Y_U)",1:DIC("S")_"&(DG1'[(U_+Y_U))")
- I DG7="Diagnosis" F I=0:0 D ICDEN1^DGPTF5 Q:X="" S X="`"_+Y D ^DIC Q:Y'>0 S DG1=DG1_+Y_U Q:$L(DG1)>235
- E F I=0:0 D ^DIC Q:Y'>0 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" 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: "
- ;I DG7="Diagnosis" S DIC(0)="XMQZ",PROMPT="Start with "_DG7_" code: " D ICDEN1^DGPTF5 Q:X="" S X="`"_+Y D ^DIC G Q:Y'>0 S DG1=$P(Y(0),U,1)_" "
- ;E S DIC("A")="Start with "_DG7_" code: " D ^DIC G Q:Y'>0 S DG1=$P(Y(0),U,1)_" "
- D ^DIC G Q:Y'>0 S DG1=$P(Y(0),U,1)_" "
- F ;I DG7="Diagnosis" S PROMPT="Go to "_DG7_" code: " D ICDEN1^DGPTF5 Q:X="" S X="`"_+Y D ^DIC G Q:Y'>0 S DG6=$P(Y(0),U,1)_"! " I DG6']DG1 W !,"Must be after start code",! G F
- ;E S DIC("A")="Go to "_DG7_" code: " D ^DIC G Q:Y'>0 S DG6=$P(Y(0),U,1)_"! " I DG6']DG1 W !,"Must be after start code",! G F
- S DIC("A")="Go to "_DG7_" code: " D ^DIC G Q:Y'>0 S DG6=$P(Y(0),U,1)_"! " 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 ;I DG7="Diagnosis" S DIC(0)="XMQZ",PROMPT="Enter "_DG7_" Code to search for: " D ICDEN1^DGPTF5 Q:X="" S X="`"_+Y D ^DIC G Q:Y'>0 S DG1=U_+Y_U D DHD G Q:'$D(X),@("E"_$E(DIC,5))
- ;E S PROMPT="Enter "_DG7_" Code to search for: " D ^DIC G Q:Y'>0 S DG1=U_+Y_U D DHD G Q:'$D(X),@("E"_$E(DIC,5))
- D ^DIC G Q:Y'>0 S DG1=U_+Y_U D DHD G Q:'$D(X),@("E"_$E(DIC,5))
- DGPTFIC ;ALB/JDS/ADL - PTF CODE SEARCH ; 26 JAN 87 @0800 [7/12/04 2:53pm]
- +1 ;;5.3;Registration;**510,559,599,669,704,744,1015**; Aug 13, 1993;Build 21
- +2 ;;ADL;;Update for CSV Project;;Mar 25, 2003
- EN ;;S DIC("S")="I $$ISVALID^ICDGTDRG(+Y,DGDAT,9)" G RANGE
- KILL DG1
- SET DIC="^ICD9("
- +1 GOTO RANGE
- E9 KILL DIC
- SET DHD=DHD_" Diagnostic Code Search"
- F9 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"""
- SET DIS("0A")="F E=0:0 X DIS(""0AA"") S D1=$O(^DGPT(D0,""M"",D1)) Q:D1'>0"
- +1 SET DG9=$SELECT('DGR:"I DG1[(U_$P(DG3,U,DGZD)_U)",1:"S DG=$$ICDDX^ICDCODE(+$P(DG3,U,DGZD),$$GETDATE^ICDGTDRG(D0)) S DG4=$S(+DG>0&($P(DG,U,10)):$P(DG,U,2),1:"""")_""!"" I DG4]DG1&(DG6]DG4)")
- +2 SET XAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=$S(DGZD<11:DGZD-4,1:DGZD-5)_U_$P(DG3,U,10)_U_$P(DG3,U,DGZD)"
- +3 SET DIS("0AA")="I $D(^DGPT(D0,""M"",D1,0)) S DG3=^(0) F DGZD=5:1:15 "_DG9_" X XAA"
- +4 SET XAAA="S DG2=DG2+1,$P(^UTILITY($J,""DG"",D0,""A""),U,DGZD)=$P($$ICDDX^ICDCODE(+$P(DG3,U,DGZD),$$GETDATE^ICDGTDRG(D0)),U,2)"
- +5 SET DIS("0AAA")="I $D(^DGPT(D0,70)) S DG3=^(70) F DGZD=10,16:1:24 "_DG9_" X XAAA"
- +6 SET L=0
- GO KILL DG9
- WRITE !,"Searching the PTF file Select fields to sort by",!
- SET DIC="^DGPT("
- SET FLDS="[DGICD]"
- SET L=0
- DO EN1^DIP
- Q KILL DIS,DGZD,DGZJ,DINS,DXS,DTOUT,DG4,DGR,DIP,DP,%,DGZJJ,DGZT,DG1,DHD,I,J,DG2,DG3,DG5,DG6,DG7,DG8,DG9,D0,DJ,DTOT,FLDS,L,PROMPT,Z,X,DIC,X1,Y,XAA,XAAA,XAAAA
- QUIT
- EN1 ;
- +1 ;;S DIC("S")="I $$ISVALID^ICDGTDRG(+Y,DGDAT,0)" G RANGE
- SET DIC="^ICD0("
- +2 GOTO RANGE
- E0 KILL DIC
- SET DHD=DHD_" Surgical Code Search"
- F0 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"""
- +1 SET DIS("0A")="F E=0:0 X DIS(""0AA"") S D1=$O(^DGPT(D0,""S"",D1)) Q:D1'>0"
- +2 SET DG9=$SELECT('DGR:"I DG1[(U_$P(DG3,U,DGZD)_U)",1:"S DG=$$ICDOP^ICDCODE(+$P(DG3,U,DGZD),$$GETDATE^ICDGTDRG(D0)) S DG4=$S(+DG>0&($P(DG,U,10)):$P(DG,U,2),1:"""")_""!"" I DG4]DG1&(DG6]DG4)")
- +3 SET XAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=(DGZD-7)_U_$P(DG3,U,1)_U_$P(DG3,U,DGZD)"
- +4 SET DIS("0AA")="I $D(^DGPT(D0,""S"",D1,0)) S DG3=^(0) F DGZD=8:1:12 "_DG9_" X XAA"
- +5 SET XAAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=DGZD_U_U_$P(DG3,U,DGZD)"
- +6 SET DIS("0AAA")="I $D(^DGPT(D0,""401P"")) S DG3=^(""401P"") F DGZD=1:1:5 "_DG9_" X XAAA"
- +7 SET XAAAA="S DG2=DG2+1,^UTILITY($J,""DG"",D0,DG2)=(DGZD-4)_U_$P(DG3,U,1)_U_$P(DG3,U,DGZD)"
- +8 SET DIS("0AAAA")="F D1=0:0 S D1=$O(^DGPT(D0,""P"",D1)) Q:D1'>0 I $D(^DGPT(D0,""P"",D1,0)) S DG3=^(0) F DGZD=5:1:9 "_DG9_" X XAAAA"
- +9 SET L=0
- +10 GOTO GO
- +11 QUIT
- OUT SET DGZJ=$X
- SET DG2=$SELECT(DGZT["ICD":"^ICD9(",1:"^ICD0(")
- SET DIO=1
- +1 FOR I=0:0
- SET I=$ORDER(^UTILITY($JOB,"DG",D0,I))
- IF I'>0
- QUIT
- SET J=^(I)
- SET Y=$PIECE($PIECE(J,U,2),".",1)
- XECUTE ^DD("DD")
- IF I>1
- WRITE !?DGZJ
- WRITE DGZT_$PIECE(J,U,1)_" "_Y
- WRITE ?DGZJ+23,$PIECE(@(DG2_"$P(J,U,3)"_",0)"),U,1)
- IF DG5
- SET DJ=$SELECT($DATA(DJ):DJ,1:0)+1
- SET DTOT=1
- +2 IF '$DATA(^UTILITY($JOB,"DG",D0,"A"))
- QUIT
- SET J=^("A")
- FOR I=10,16:1:24
- SET K=$PIECE(J,U,I)
- IF K]""
- WRITE !?DGZJ,$SELECT(I=10:"PRINCIPAL DIAGNOSIS",1:"ICD "_(I-14)),?DGZJ+23,K
- IF DG5
- SET DJ=$SELECT($DATA(DJ):DJ,1:0)+1
- SET DTOT=1
- +3 QUIT
- 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 IF DG7="Diagnosis"
- FOR I=0:0
- DO ICDEN1^DGPTF5
- IF X=""
- QUIT
- SET X="`"_+Y
- DO ^DIC
- IF Y'>0
- QUIT
- SET DG1=DG1_+Y_U
- IF $LENGTH(DG1)>235
- QUIT
- +2 IF '$TEST
- FOR I=0:0
- DO ^DIC
- IF Y'>0
- 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
- 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
- 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",!
- RANGE SET DIC(0)="AMEQZ"
- WRITE !,"Search by Range or Exact match: E// "
- SET Z="^RANGE^EXACT MATCH"
- READ X:DTIME
- 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)
- +1 SET DG7=$SELECT(DIC[9:"Diagnosis",1:"Surgical")
- IF 'DGR
- GOTO E
- +2 SET DIC("A")="Start with "_DG7_" code: "
- +3 ;I DG7="Diagnosis" S DIC(0)="XMQZ",PROMPT="Start with "_DG7_" code: " D ICDEN1^DGPTF5 Q:X="" S X="`"_+Y D ^DIC G Q:Y'>0 S DG1=$P(Y(0),U,1)_" "
- +4 ;E S DIC("A")="Start with "_DG7_" code: " D ^DIC G Q:Y'>0 S DG1=$P(Y(0),U,1)_" "
- +5 DO ^DIC
- IF Y'>0
- GOTO Q
- SET DG1=$PIECE(Y(0),U,1)_" "
- F ;I DG7="Diagnosis" S PROMPT="Go to "_DG7_" code: " D ICDEN1^DGPTF5 Q:X="" S X="`"_+Y D ^DIC G Q:Y'>0 S DG6=$P(Y(0),U,1)_"! " I DG6']DG1 W !,"Must be after start code",! G F
- +1 ;E S DIC("A")="Go to "_DG7_" code: " D ^DIC G Q:Y'>0 S DG6=$P(Y(0),U,1)_"! " I DG6']DG1 W !,"Must be after start code",! G F
- +2 SET DIC("A")="Go to "_DG7_" code: "
- DO ^DIC
- IF Y'>0
- GOTO Q
- SET DG6=$PIECE(Y(0),U,1)_"! "
- 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
- E ;I DG7="Diagnosis" S DIC(0)="XMQZ",PROMPT="Enter "_DG7_" Code to search for: " D ICDEN1^DGPTF5 Q:X="" S X="`"_+Y D ^DIC G Q:Y'>0 S DG1=U_+Y_U D DHD G Q:'$D(X),@("E"_$E(DIC,5))
- +1 ;E S PROMPT="Enter "_DG7_" Code to search for: " D ^DIC G Q:Y'>0 S DG1=U_+Y_U D DHD G Q:'$D(X),@("E"_$E(DIC,5))
- +2 DO ^DIC
- IF Y'>0
- GOTO Q
- SET DG1=U_+Y_U
- DO DHD
- IF '$DATA(X)
- GOTO Q
- GOTO @("E"_$EXTRACT(DIC,5))
