- 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 ;
