DGPTFM0 ;ALB/MAC/ADL - ROUTINE TO DISPLAY PROCEDURE CODES ON THE MAS SCREEN IN PTF LOAD/EDIT ; AUG 1 1989@1200
;;5.3;Registration;**510,517,1015**;Aug 13, 1993;Build 21
;;ADL;;Update for CSV Project;;Mar 25, 2003
EN S I=0 K P F I1=1:1 S I=$O(^DGPT(PTF,"P",I)) Q:I'>0 S P(I1)=^(I,0),P(I1,1)=I
S P2=0,(L6,P)=0 F J=ST:2:(I1-1) S NL=1,L5=0,L6=J D PD2 S L5=1,L6=J+1 D:$D(P(L6)) PD2 D PD G PRO1^DGPTFM:$Y>11 W !
G PRO^DGPTFM
PD F J1=1:1:5 S L=$P(P(J),U,J1+4),L1=0,L3=1 D:+L PD1 S L1=1,L=$S($D(P(J+1)):$P(P(J+1),U,J1+4),1:"") D:+L PD1
Q
PD1 S DGPTTMP=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)),L2=$S(+DGPTTMP>0:$P(DGPTTMP,U,2,99),1:""),P2=P2+1,L4=$P(L2,"^",1),L4=L4_$E(" ",1,3-$L($P(L4,".",2))) D Q
. W:L3 ! S:L3 L3=0 W ?L1*40,$J(P2,3)," ",$J(L4,7)," ",$E($P(L2,U,4),1,25) K P2(P2) S P2(P2)=J+L1_U_J1
PD2 S Y=+P(L6) D D^DGPTUTL W:NL ! S:NL NL=0 W ?L5*40,L6,"-Procedure date: ",Y
Q
PRC K DGZSER,DGZDIAG,DGZPRO S DGZSUR=1,J=-1 G PRO1^DGPTFM:$Y>11 K P1,P2 S ST=1,P2=0
S ST=1 G EN
;
C ; -- help for surgery
W !!,"Enter the item #'s of the operation codes, 1-",S2,", that you wish to delete:"
F L=1:1:S2 Q:'$D(S2(L)) I $D(S(+S2(L),1)),$D(^DGPT(PTF,"S",+S(+S2(L),1),0)) S DGPTTMP=$$ICDOP^ICDCODE(+$P(^(0),"^",7+$P(S2(L),"^",2)),$$GETDATE^ICDGTDRG(PTF)) I +DGPTTMP>0 D
. W !?5,$J(L,2),": ",$J($P(DGPTTMP,"^",2),7)," - ",$E($P(DGPTTMP,"^",5),1,40)
Q
;
DX ; -- help for dx's
W !!,"Enter the item #'s of the diagnoses, 1-",M2,", that you wish to delete:"
S UTL="^UTILITY($J,""M2"")"
F L=1:1:M2 Q:'$D(@UTL@(L)) I $D(^DGPT(PTF,"M",+@UTL@(L),0)) S DGPTTMP=$$ICDDX^ICDCODE(+$P(^(0),"^",4+$P(@UTL@(L),"^",2)),$$GETDATE^ICDGTDRG(PTF)) I +DGPTTMP>0 D
. W !?5,$J(L,2),": ",$J($P(DGPTTMP,"^",2),7)," - ",$E($P(DGPTTMP,"^",4),1,40)
K UTL,L Q
;
Q ; -- help for procedure
W !!,"Type the number of the procedure - not the procedure code -"
W !,"for the procedure you wish to delete.",!
W !,"However, this deletion function is not applicable"
W !,"for procedures listed under 'Procedure date:' displays."
W !,"Delete these codes using the 601 screen functionality."
Q
;
D G DEL:Z
I $D(M2),'M2 W !,"No codes to delete",! H 2 G ^DGPTFM
D1 R !!,"Enter the item #'s of the ICD Diagnosis codes to delete: ",A1:DTIME
I A1'?1N.NP G ^DGPTFM:"^"[A1 W:A1'["?" " ???",*7 D DX G D1
S A=A_A1
DEL D EXPL^DGPTUTL
K X,A1 S DIE="^DGPT("_PTF_",""M"",",DA(1)=PTF W !!
F J=1:1 S DP=45.02,L=+$P(DGA,",",J) Q:'L S L1=$S($D(^UTILITY($J,"M2",L)):^(L),1:"Undefined, ") W:'L1 " ",L,"-",L1 I L1 S DA=+L1,DR=4+$P(L1,U,2)_"///@",DA(1)=PTF D ^DIE K DR W " ",L,"-Deleted, " W:$X>70 !
S DGPTF=PTF,DGMOV=+L1 D CHK501^DGPTSCAN
H 2 G ^DGPTFM
;
DGPTFM0 ;ALB/MAC/ADL - ROUTINE TO DISPLAY PROCEDURE CODES ON THE MAS SCREEN IN PTF LOAD/EDIT ; AUG 1 1989@1200
+1 ;;5.3;Registration;**510,517,1015**;Aug 13, 1993;Build 21
+2 ;;ADL;;Update for CSV Project;;Mar 25, 2003
EN SET I=0
KILL P
FOR I1=1:1
SET I=$ORDER(^DGPT(PTF,"P",I))
IF I'>0
QUIT
SET P(I1)=^(I,0)
SET P(I1,1)=I
+1 SET P2=0
SET (L6,P)=0
FOR J=ST:2:(I1-1)
SET NL=1
SET L5=0
SET L6=J
DO PD2
SET L5=1
SET L6=J+1
IF $DATA(P(L6))
DO PD2
DO PD
IF $Y>11
GOTO PRO1^DGPTFM
WRITE !
+2 GOTO PRO^DGPTFM
PD FOR J1=1:1:5
SET L=$PIECE(P(J),U,J1+4)
SET L1=0
SET L3=1
IF +L
DO PD1
SET L1=1
SET L=$SELECT($DATA(P(J+1)):$PIECE(P(J+1),U,J1+4),1:"")
IF +L
DO PD1
+1 QUIT
PD1 SET DGPTTMP=$$ICDOP^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF))
SET L2=$SELECT(+DGPTTMP>0:$PIECE(DGPTTMP,U,2,99),1:"")
SET P2=P2+1
SET L4=$PIECE(L2,"^",1)
SET L4=L4_$EXTRACT(" ",1,3-$LENGTH($PIECE(L4,".",2)))
Begin DoDot:1
+1 IF L3
WRITE !
IF L3
SET L3=0
WRITE ?L1*40,$JUSTIFY(P2,3)," ",$JUSTIFY(L4,7)," ",$EXTRACT($PIECE(L2,U,4),1,25)
KILL P2(P2)
SET P2(P2)=J+L1_U_J1
End DoDot:1
QUIT
PD2 SET Y=+P(L6)
DO D^DGPTUTL
IF NL
WRITE !
IF NL
SET NL=0
WRITE ?L5*40,L6,"-Procedure date: ",Y
+1 QUIT
PRC KILL DGZSER,DGZDIAG,DGZPRO
SET DGZSUR=1
SET J=-1
IF $Y>11
GOTO PRO1^DGPTFM
KILL P1,P2
SET ST=1
SET P2=0
+1 SET ST=1
GOTO EN
+2 ;
C ; -- help for surgery
+1 WRITE !!,"Enter the item #'s of the operation codes, 1-",S2,", that you wish to delete:"
+2 FOR L=1:1:S2
IF '$DATA(S2(L))
QUIT
IF $DATA(S(+S2(L),1))
IF $DATA(^DGPT(PTF,"S",+S(+S2(L),1),0))
SET DGPTTMP=$$ICDOP^ICDCODE(+$PIECE(^(0),"^",7+$PIECE(S2(L),"^",2)),$$GETDATE^ICDGTDRG(PTF))
IF +DGPTTMP>0
Begin DoDot:1
+3 WRITE !?5,$JUSTIFY(L,2),": ",$JUSTIFY($PIECE(DGPTTMP,"^",2),7)," - ",$EXTRACT($PIECE(DGPTTMP,"^",5),1,40)
End DoDot:1
+4 QUIT
+5 ;
DX ; -- help for dx's
+1 WRITE !!,"Enter the item #'s of the diagnoses, 1-",M2,", that you wish to delete:"
+2 SET UTL="^UTILITY($J,""M2"")"
+3 FOR L=1:1:M2
IF '$DATA(@UTL@(L))
QUIT
IF $DATA(^DGPT(PTF,"M",+@UTL@(L),0))
SET DGPTTMP=$$ICDDX^ICDCODE(+$PIECE(^(0),"^",4+$PIECE(@UTL@(L),"^",2)),$$GETDATE^ICDGTDRG(PTF))
IF +DGPTTMP>0
Begin DoDot:1
+4 WRITE !?5,$JUSTIFY(L,2),": ",$JUSTIFY($PIECE(DGPTTMP,"^",2),7)," - ",$EXTRACT($PIECE(DGPTTMP,"^",4),1,40)
End DoDot:1
+5 KILL UTL,L
QUIT
+6 ;
Q ; -- help for procedure
+1 WRITE !!,"Type the number of the procedure - not the procedure code -"
+2 WRITE !,"for the procedure you wish to delete.",!
+3 WRITE !,"However, this deletion function is not applicable"
+4 WRITE !,"for procedures listed under 'Procedure date:' displays."
+5 WRITE !,"Delete these codes using the 601 screen functionality."
+6 QUIT
+7 ;
D IF Z
GOTO DEL
+1 IF $DATA(M2)
IF 'M2
WRITE !,"No codes to delete",!
HANG 2
GOTO ^DGPTFM
D1 READ !!,"Enter the item #'s of the ICD Diagnosis codes to delete: ",A1:DTIME
+1 IF A1'?1N.NP
IF "^"[A1
GOTO ^DGPTFM
IF A1'["?"
WRITE " ???",*7
DO DX
GOTO D1
+2 SET A=A_A1
DEL DO EXPL^DGPTUTL
+1 KILL X,A1
SET DIE="^DGPT("_PTF_",""M"","
SET DA(1)=PTF
WRITE !!
+2 FOR J=1:1
SET DP=45.02
SET L=+$PIECE(DGA,",",J)
IF 'L
QUIT
SET L1=$SELECT($DATA(^UTILITY($JOB,"M2",L)):^(L),1:"Undefined, ")
IF 'L1
WRITE " ",L,"-",L1
IF L1
SET DA=+L1
SET DR=4+$PIECE(L1,U,2)_"///@"
SET DA(1)=PTF
DO ^DIE
KILL DR
WRITE " ",L,"-Deleted, "
IF $X>70
WRITE !
+3 SET DGPTF=PTF
SET DGMOV=+L1
DO CHK501^DGPTSCAN
+4 HANG 2
GOTO ^DGPTFM
+5 ;
