DGPTFM0 ;ALB/MAC/ADL/PLT - ROUTINE TO DISPLAY PROCEDURE CODES ON THE MAS SCREEN IN PTF LOAD/EDIT ;AUG 1 1989@1200
;;5.3;Registration;**510,517,850,884**;Aug 13, 1993;Build 31
;;Per VA Directive 6402, this routine should not be modified.
;
;;ADL;;Update for CSV Project;;Mar 25, 2003
EN ;
N EFFDATE,IMPDATE
D EFFDATE^DGPTIC10(PTF)
K P,P1,P2 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 I P(I1)']"" K P(I1) S I1=I1-1
S DGPC=I1-1
S (L6,P,P2)=0 F J=ST:1:(I1-1) S NL=1,L5=0,L6=J D PD2 D PD G PRO1^DGPTFM:$Y>12 W !
G PRO^DGPTFM
PD ;
;F J1=1:1:5 S L=$P($G(P(J)),U,J1+4),L1=0,L3=1 D:+L PD1
D PTFICD^DGPTFUT(601,PTF,P(J,1),.DGX601)
S J1=0 F S J1=$O(DGX601(J1)) QUIT:'J1 S L=DGX601(J1),L1=0,L3=1 D:+L PD1
K DGX601
QUIT
PD1 ;
N J2
S J2=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE)
S P2=P2+1
W !,?L1,$J(P2,3)," " D WRITECOD^DGPTIC10("PROC",+L,EFFDATE,1,0,0) W $S(+J2<1!('$P(J2,U,10)):"*",1:"")
K P2(P2) S P2(P2)=J+L1_U_J1_U_(+L)
I $Y>(IOSL-4) D PGBR D WR^DGPTFM W !
QUIT
PD2 ;
S Y=+$G(P(L6)) D D^DGPTUTL W !,L6,"-Procedure date: ",Y,$$GETLABEL^DGPTIC10(EFFDATE,"P")
Q
PRC ;
K DGZSER,DGZDIAG,DGZPRO S DGZSUR=1,J=0
;G:$G(DGMMORE) PRO1^DGPTFM:$Y>12
K P1,P2 S ST=1,P2=0
G:$G(DGMMORE) PRO1^DGPTFM:$Y>12
S ST=1 G EN
;
C ; -- help for surgery delete code
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)) D
. W !?5,$J(L,2),": " D WRITECOD^DGPTIC10("PROC",$P(S2(L),U,3),EFFDATE,1,0,0)
. ;W !,"here",*7
. I $Y>(IOSL-4) D PGBR W @IOF
. QUIT
QUIT
;
DX ; -- help for movment delete 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)) D:$P(@UTL@(L),U,3) ;I $D(^DGPT(PTF,"M",+@UTL@(L),0)) D
. N DGPTTMP
. W !?5,$J(L,2),": " D WRITECOD^DGPTIC10("DIAG",$P(@UTL@(L),U,3),EFFDATE,1,0,0)
. S DGMPOA=$P(@UTL@(L),U,4),DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",$P(@UTL@(L),U,3),EFFDATE)
. I $P(DGPTTMP,U,20)=30 W:$X>73 !," " W " (POA=",$S(DGMPOA]"":DGMPOA,1:"''"),")"
. I $Y>(IOSL-4) D PGBR W @IOF
. QUIT
K UTL,L Q
;
Q ; -- help for procedure delete code
W !!,"Enter the item #'s of the procedure codes, 1-",P2,", that you wish to delete"
F L=1:1:P2 Q:'$D(P2(L)) I $D(P(+P2(L),1)),$D(^DGPT(PTF,"P",+P(+P2(L),1),0)) D
. W !?5,$J(L,2),": " D WRITECOD^DGPTIC10("PROC",$P(P2(L),U,3),EFFDATE,1,0,0)
. I $Y>(IOSL-4) D PGBR W @IOF
. QUIT
QUIT
;
; -- help for procedure 401p delete code
Q1 W !!,"Type the number of the procedure code, 1-",P2P," for 401P transactions"
W !,"(admissions prior to 10/1/87) you wish to delete.",!
F L=1:1:P2P Q:'$D(P2P(L)) D
. N N
. S N=$$ICDDATA^ICDXCODE("PROC",$P($G(^DGPT(PTF,"401P")),U,P2P(L)),EFFDATE)
. W !,$J(L,3)," " D WRITECOD^DGPTIC10("PROC",$P($G(^DGPT(PTF,"401P")),U,P2P(L)),EFFDATE,1,0,0)
. W $S(+N<1!('$P(N,U,10)):"*",1:"")
. I $Y>(IOSL-4) D PGBR W @IOF
. QUIT
;W !,"Howwever, this deletion function is not applicable"
;W !,"for procedures listed under 'Procedure date:' displays."
;W !,"Delete these codes using the 601 screen functionality."
QUIT
;
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=$$FLDNUM^DILFD(45.02,"ICD "_$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
Q
;
PGBR N DIR,X,Y S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFM0 3907 printed Sep 23, 2025@20:28:09 Page 2
DGPTFM0 ;ALB/MAC/ADL/PLT - ROUTINE TO DISPLAY PROCEDURE CODES ON THE MAS SCREEN IN PTF LOAD/EDIT ;AUG 1 1989@1200
+1 ;;5.3;Registration;**510,517,850,884**;Aug 13, 1993;Build 31
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;;ADL;;Update for CSV Project;;Mar 25, 2003
EN ;
+1 NEW EFFDATE,IMPDATE
+2 DO EFFDATE^DGPTIC10(PTF)
+3 KILL P,P1,P2
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
IF P(I1)']""
KILL P(I1)
SET I1=I1-1
+4 SET DGPC=I1-1
+5 SET (L6,P,P2)=0
FOR J=ST:1:(I1-1)
SET NL=1
SET L5=0
SET L6=J
DO PD2
DO PD
if $Y>12
GOTO PRO1^DGPTFM
WRITE !
+6 GOTO PRO^DGPTFM
PD ;
+1 ;F J1=1:1:5 S L=$P($G(P(J)),U,J1+4),L1=0,L3=1 D:+L PD1
+2 DO PTFICD^DGPTFUT(601,PTF,P(J,1),.DGX601)
+3 SET J1=0
FOR
SET J1=$ORDER(DGX601(J1))
if 'J1
QUIT
SET L=DGX601(J1)
SET L1=0
SET L3=1
if +L
DO PD1
+4 KILL DGX601
+5 QUIT
PD1 ;
+1 NEW J2
+2 SET J2=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE)
+3 SET P2=P2+1
+4 WRITE !,?L1,$JUSTIFY(P2,3)," "
DO WRITECOD^DGPTIC10("PROC",+L,EFFDATE,1,0,0)
WRITE $SELECT(+J2<1!('$PIECE(J2,U,10)):"*",1:"")
+5 KILL P2(P2)
SET P2(P2)=J+L1_U_J1_U_(+L)
+6 IF $Y>(IOSL-4)
DO PGBR
DO WR^DGPTFM
WRITE !
+7 QUIT
PD2 ;
+1 SET Y=+$GET(P(L6))
DO D^DGPTUTL
WRITE !,L6,"-Procedure date: ",Y,$$GETLABEL^DGPTIC10(EFFDATE,"P")
+2 QUIT
PRC ;
+1 KILL DGZSER,DGZDIAG,DGZPRO
SET DGZSUR=1
SET J=0
+2 ;G:$G(DGMMORE) PRO1^DGPTFM:$Y>12
+3 KILL P1,P2
SET ST=1
SET P2=0
+4 if $GET(DGMMORE)
if $Y>12
GOTO PRO1^DGPTFM
+5 SET ST=1
GOTO EN
+6 ;
C ; -- help for surgery delete code
+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))
Begin DoDot:1
+3 WRITE !?5,$JUSTIFY(L,2),": "
DO WRITECOD^DGPTIC10("PROC",$PIECE(S2(L),U,3),EFFDATE,1,0,0)
+4 ;W !,"here",*7
+5 IF $Y>(IOSL-4)
DO PGBR
WRITE @IOF
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
DX ; -- help for movment delete 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 ;I $D(^DGPT(PTF,"M",+@UTL@(L),0)) D
FOR L=1:1:M2
if '$DATA(@UTL@(L))
QUIT
if $PIECE(@UTL@(L),U,3)
Begin DoDot:1
+4 NEW DGPTTMP
+5 WRITE !?5,$JUSTIFY(L,2),": "
DO WRITECOD^DGPTIC10("DIAG",$PIECE(@UTL@(L),U,3),EFFDATE,1,0,0)
+6 SET DGMPOA=$PIECE(@UTL@(L),U,4)
SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",$PIECE(@UTL@(L),U,3),EFFDATE)
+7 IF $PIECE(DGPTTMP,U,20)=30
if $X>73
WRITE !," "
WRITE " (POA=",$SELECT(DGMPOA]"":DGMPOA,1:"''"),")"
+8 IF $Y>(IOSL-4)
DO PGBR
WRITE @IOF
+9 QUIT
End DoDot:1
+10 KILL UTL,L
QUIT
+11 ;
Q ; -- help for procedure delete code
+1 WRITE !!,"Enter the item #'s of the procedure codes, 1-",P2,", that you wish to delete"
+2 FOR L=1:1:P2
if '$DATA(P2(L))
QUIT
IF $DATA(P(+P2(L),1))
IF $DATA(^DGPT(PTF,"P",+P(+P2(L),1),0))
Begin DoDot:1
+3 WRITE !?5,$JUSTIFY(L,2),": "
DO WRITECOD^DGPTIC10("PROC",$PIECE(P2(L),U,3),EFFDATE,1,0,0)
+4 IF $Y>(IOSL-4)
DO PGBR
WRITE @IOF
+5 QUIT
End DoDot:1
+6 QUIT
+7 ;
+8 ; -- help for procedure 401p delete code
Q1 WRITE !!,"Type the number of the procedure code, 1-",P2P," for 401P transactions"
+1 WRITE !,"(admissions prior to 10/1/87) you wish to delete.",!
+2 FOR L=1:1:P2P
if '$DATA(P2P(L))
QUIT
Begin DoDot:1
+3 NEW N
+4 SET N=$$ICDDATA^ICDXCODE("PROC",$PIECE($GET(^DGPT(PTF,"401P")),U,P2P(L)),EFFDATE)
+5 WRITE !,$JUSTIFY(L,3)," "
DO WRITECOD^DGPTIC10("PROC",$PIECE($GET(^DGPT(PTF,"401P")),U,P2P(L)),EFFDATE,1,0,0)
+6 WRITE $SELECT(+N<1!('$PIECE(N,U,10)):"*",1:"")
+7 IF $Y>(IOSL-4)
DO PGBR
WRITE @IOF
+8 QUIT
End DoDot:1
+9 ;W !,"Howwever, this deletion function is not applicable"
+10 ;W !,"for procedures listed under 'Procedure date:' displays."
+11 ;W !,"Delete these codes using the 601 screen functionality."
+12 QUIT
+13 ;
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=$$FLDNUM^DILFD(45.02,"ICD "_$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 QUIT
+6 ;
PGBR NEW DIR,X,Y
SET DIR(0)="E"
SET DIR("A")="Enter RETURN to continue"
DO ^DIR
QUIT
+1 ;
