DGPTFM0.m

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 ---DGPTFM0   3907     printed  Feb 19, 2025@00:18:18                                                                                                                                                                                                     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       ;