- DGPTFM ;ALB/MTC/PLT - PTF OP-PRO-DIAG ;07/01/2015 8:03 AM
- ;;5.3;Registration;**510,517,590,594,606,635,683,696,664,850,884,1057**;Aug 13, 1993;Build 17
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- K X1,M,S,P,M1,M2,M3,S1,S2,PS2,P1,P2,P1P,P2P,SDCLY,^TMP("PTF",$J)
- N EFFDATE,IMPDATE,DGMOVCNT,DGSURCNT,DGPROCNT,DGMMORE,DGPMORE
- D EFFDATE^DGPTIC10(PTF)
- S DGMOVCNT=0,DGSURCNT=0,DGPROCNT=0
- S I=0 F I1=1:1 S I=$O(^DGPT(PTF,"M",I)) Q:'I S DGMOVCNT=$G(DGMOVCNT)+1
- S I=0 F I1=1:1 S I=$O(^DGPT(PTF,"S",I)) Q:'I S DGSURCNT=$G(DGSURCNT)+1
- S I=0 F I1=1:1 S I=$O(^DGPT(PTF,"P",I)) Q:'I S DGPROCNT=$G(DGPROCNT)+1
- S I=0 F I1=1:1:5 S I=$P($G(^DGPT(PTF,"401P")),U,I1) I +I S DGPRCNT=$G(DGPRCNT)+1
- S DGMMORE=$G(DGSURCNT)+$G(DGPROCNT)+$G(DGPRCNT)
- S DGPMORE=$G(DGPROCNT)+$G(DGPRCNT)
- ;
- GET ;set m,m3 local array of movement records
- S I=0 F I1=1:1 S I=$O(^DGPT(PTF,"M",I)) Q:'I D
- . S M(I1)=^(I,0),M3(+M(I1))=M(I1) ;,M(I1,82)=$G(^DGPT(PTF,"M",I,82))
- . I $D(^DGPT(PTF,"M",I,"P")) S $P(M(I1),U,20)=^("P")
- . QUIT
- ;sort m array in chronological order for display, not m3
- K MT D ORDER^DGPTF K MT
- D GETVAR^DGPTFM6,CL^SDCO21(DFN,$P(^DGPT(PTF,0),U,2),"",.SDCLY),MOB^DGPTFM2
- S DGPC=I1-1
- D WR ; creates header
- K M1,M2,^UTILITY($J)
- S ST=1,M2=0
- DIAG ;
- K DGZSER,DGZPRO,DGZSUR S DGZDIAG=1
- G PRO1:$Y>16 W !
- F J=ST:1:PM S NL=1,L5=0,L6=J D WD2,WD G PRO1:$Y>16 D WD3^DGPTFM8 W !
- S ST=1 G SER
- WD ;
- N DGMPOA
- D EFFDATE^DGPTIC10(PTF)
- W !?2,"Movement Diagnosis: ",$$GETLABEL^DGPTIC10(DGPTDAT,"D")
- ;F J1=1:1:11 I J1'=6 S L=$P(M(J),U,J1+4),L1=0,L3=1 I +L D
- D PTFICD^DGPTFUT(501,PTF,+M(J),.DGX501)
- S J1=0 F S J1=$O(DGX501(J1)) QUIT:'J1 S L=DGX501(J1),L1=0,L3=1 I +L D
- . S DGMPOA=$P(L,U,2)
- . D:+L WD1
- . QUIT
- K DGX501
- QUIT
- WD1 ;
- S N=$$ICDDATA^ICDXCODE("DIAG",+L,EFFDATE),M2=M2+1
- W !,?L1,$J(M2,3)," "
- D WRITECOD^DGPTIC10("DIAG",+L,EFFDATE,1,0,0)
- I $P(N,U,20)=30 W:$X>73 !," " W " (POA=",$S(DGMPOA]"":DGMPOA,1:"''"),")"
- W $S(+N<1!('$P(N,U,10)):"*",1:"")
- K ^UTILITY($J,"M2",M2) S ^UTILITY($J,"M2",M2)=+M(J+L1)_U_J1_U_(+L)_U_DGMPOA
- I $Y>(IOSL-4) D PGBR W @IOF,HEAD,?70 S Z="<MAS>" D Z W !
- QUIT
- WD2 ;
- N Z3
- W !?L5,"Move #",+L6 S Z=M(L6),Z3=M3(+Z) W:+Z=1 " D/C" S Y=$P(Z,U,10)\1 D D^DGPTUTL W " ",Y," "
- W " <",$S($P(Z3,U,18)=1:"",1:"N"),"SC"_$S($P(Z3,U,26)="Y":",AO",1:"")_$S($P(Z3,U,27)="Y":",IR",1:"")_$S($P(Z3,U,28)="Y":",SWAC",1:"")_$S($P(Z3,U,32)="Y":",SHAD",1:"")_">"
- I $D(^DIC(42.4,+$P(Z,U,2),0)) D
- . I $P(^DIC(42.4,+$P(Z,U,2),0),U,2)'="" W $E($P(^DIC(42.4,+$P(Z,U,2),0),U,2),1,10)
- . E W $E($P(^(0),U,1),1,10) ;^(0) references global in line above
- . QUIT
- QUIT
- ;
- NDG D WR S I=0 K M,M1,M2 S M2=0 F I1=1:1 S I=$O(^DGPT(PTF,"M",I)) Q:I'>0 S M(I1)=^(I,0) ;,M(I1,82)=$G(^DGPT(PTF,"M",I,82))
- ;sort m array in chronological order for display
- S PM=I1-1 D ORDER^DGPTF K MT G DIAG:$D(ST) G GET S ST=1
- ;
- SER ;
- K DGZDIAG,DGZPRO,DGZSUR
- S DGZSER=1
- ;G PRO1:$Y>19
- K S1,S2
- S S2=0 G SERV:ST G PRO
- ;
- SERV ;
- ;F J=ST:2:SU S NL=1,L5=0,L6=J D SD2 S L5=1,L6=J+1 D:$D(S(L6)) SD2 D SD G PRO1:$Y>11 D SD3^DGPTFM8 G PRO1:$Y>11 W !
- F J=ST:1:SU S NL=1,L5=0,L6=J D SD2,SD D SD3^DGPTFM8 G:(J<SU) PRO1:$Y>12 W !
- K DGZSER
- G PRC^DGPTFM0
- SD ;
- ;F J1=1:1:5 S L=$P(S(J),U,J1+7),L1=0,L3=1 D:+L SD1
- D PTFICD^DGPTFUT(401,PTF,S(J,1),.DGX401)
- S J1=0 F S J1=$O(DGX401(J1)) QUIT:'J1 S L=DGX401(J1),L1=0,L3=1 D:+L SD1
- K DGX401
- QUIT
- SD1 ;
- S N=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE)
- S S2=S2+1
- W !,?L1,$J(S2,3)," " D WRITECOD^DGPTIC10("PROC",+L,EFFDATE,1,0,0) W $S(+N<1!('$P(N,U,10)):"*",1:"")
- K S2(S2) S S2(S2)=J+L1_U_J1_U_(+L)
- I $Y>(IOSL-4) D PGBR W @IOF,HEAD,?70 S Z="<MAS>" D Z W !
- Q
- ;
- SD2 ;
- S Y=+S(L6) D D^DGPTUTL W !?L5,L6,"-Surgery date: ",Y,$$GETLABEL^DGPTIC10(EFFDATE,"P")
- Q
- NSR K S,S1,S2 S I=0 F I1=1:1 S I=$O(^DGPT(PTF,"S",I)) Q:I'>0 S S(I1)=^(I,0),S(I1,1)=I
- S S2=0,SU=I1-1 D WR G SERV
- ;
- WR W @IOF,HEAD,?70 S Z="<MAS>" D Z
- W !,?30,"Initial Date Of Service: ",$$EXTERNAL^DILFD(45,14,,$G(DGIDTS)) ; DG*5.3*1057
- Q
- PRO ;load 401p code before 2871000
- K DGZSER,DGZDIAG,DGZSUR
- S DGZPRO=1
- G:$G(DGPRCNT) PRO1:$Y>14
- K P1P,P2P S ST=1,P2P=0
- G NPR:'$D(PROC)
- ;
- PROC ; Display procedures in field 45.01 - 45.05
- ;
- G PRO1:$Y>14 ;D:$Y>14 WR
- S PROC=$S($D(^DGPT(PTF,"401P")):^("401P"),1:"")
- F PR=1:1:5 S DGPROC=$G(DGPROC)_$P(PROC,"^",PR)
- K PR
- W:DGPROC]"" !,"Procedures: ",$$GETLABEL^DGPTIC10(DGPTDAT,"P")
- F J1=1:1:5 S L=$P(PROC,"^",J1) I L'="" S P2P=P2P+1 D
- . S N=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE)
- . S L2=$S(N:$P(N,U,2,99),1:"")
- . W !,$J(P2P,3)," " D WRITECOD^DGPTIC10("PROC",+L,EFFDATE,1,0,0)
- . W $S(+N<1!('$P(N,U,10)):"*",1:"")
- . K P2P(P2P) S P2P(P2P)=J1 W:$X>45 !
- K DGZSER,DGZPRO,DGZDIAG,DGZSUR
- ;
- ENC ;G PRO1:$Y>7,PRO1:'$P(DGZPRF,U,3)
- G PRO1:'$P(DGZPRF,U,3)
- G PRO1:$Y>12
- ;
- PF S PS2=0,J=+DGZPRF,Y=+DGZPRF(J),DGSTRT=$S(+$P(DGZPRF,U,4):$P(DGZPRF,U,4),1:4),DGLST=0
- D CL^SDCO21(DFN,+DGZPRF(J),"",.SDCLY),ICDINFO^DGAPI(DFN,PTF),XREF^DGPTFM21 ; load SCI info and DGN's for this service date
- D D^DGPTUTL W !,J,"-CPT Capture Date/Time: ",Y W:($P(DGZPRF,U,2)-1!($G(PGBRK))) " (cont.)"
- I $P(DGZPRF(J),U,2) W !,?5,"Referring or Ordering Provider: " S L=$P(DGZPRF(J),U,2) D PRV
- W !,?5,"Rendering Provider: " S L=$P(DGZPRF(J),U,3) D PRV
- I $P(DGZPRF(J),U,5) W !,?5,"Rendering Location: ",$P($G(^SC($P(DGZPRF(J),U,5),0)),U)
- S (L1,PGBRK)=0
- F K=$P(DGZPRF,U,2):1 Q:'$D(DGZPRF(J,K)) I '$G(DGZPRF(J,K,9)) S PS2=PS2+1 W !,?2,PS2," " D CPT^DGPTUTL1 D Q:$Y+$G(DGZPRF(J,K+1,1))>16!($G(PGBRK))
- .; Add 801 logic
- . W !,?4 S $P(DS,"-",21)="" W DS," Related Diagnosis",$$GETLABEL^DGPTIC10(+DGZPRF(J),"D")," ",DS
- . F L1=DGSTRT:1:11 S DGLOC=$S(L1<8:L1,1:L1+7),CD=$P(DGZPRF(J,K),U,DGLOC) I CD D I $Y+$G(CKSCI)>16 S PGBRK=1 Q
- . . S N=$$ICDDATA^ICDXCODE("DIAG",CD,+DGZPRF(J)) ;,N=$S(N:$P(N,U,2,99),1:"")
- . . D WRITECOD^DGPTIC10("DIAG",CD,+DGZPRF(J),2,1,8)
- . . W $S(+N<1!('$P(N,U,10)):"*",1:"")
- . . D CKSCI($P(DGZPRF(J,K),U,DGLOC))
- . S PS2(PS2)=J_U_K,CD=1,DGLOC=0,DGSTRT=4
- I L1'=11,$S(L1<8:$P($G(DGZPRF(J,K)),U,L1+1,7),1:"")_$P($G(DGZPRF(J,K)),U,$S(L1<8:15,1:L1+8),18)?."^" S L1=11
- I L1=11 S $P(DGZPRF,U,1,2)=$S($D(DGZPRF(J,K+1)):J_U_(K+1),1:J+1_U_1),$P(DGZPRF,U,4)="",PGBRK=0
- E S $P(DGZPRF,U,1,2)=J_U_K,$P(DGZPRF,U,4)=L1+1
- K I,K,L,L1,CD,N,DS G PRO1
- ;
- CKSCI(IEN) ;print SCI for each Diagnosis code
- N DGINFO Q:'$D(XREF(IEN))
- S DGINFO=$G(^DGICD9(46.1,(XREF(IEN)),0)),CKSCI=0
- I 'DGINFO Q
- F I=3,7,1,2,4,5,6,8 I $D(SDCLY(I)) S L=$S(I=3:8,I<4:8+I,1:7+I) D
- .W ?45 S M=1,CKSCI=CKSCI+1
- .W !?8
- .W $P("Treated for AO Condition^Treated for IR Condition^Treated for SC Condition^Exposed to SW Asia Conditions^Treatment for MST^Treatment for Head/Neck CA^Related to Combat^Treatment for SHAD Condition",U,I)
- .W ": ",$S($P(DGINFO,U,($S(I<3:I+2,I=3:2,1:I+1))):"YES",1:"NO"),!
- Q ;CKSCI
- ;
- NPR S ST=1,PROC=$S($D(^DGPT(PTF,"401P")):^("401P"),1:"") D WR G PRO
- ;
- NPS D WR G PF
- ;
- DONE G EN1^DGPTF4
- PRO1 ;SET MENU TYPE AND DISPLAY MENU
- N ICDVDT,ICPTVDT
- I $G(PTF)'="",$G(EFFDATE)="" D EFFDATE^DGPTIC10(PTF)
- S (ICDVDT,ICPTVDT)=$S($G(EFFDATE)'="":EFFDATE,$D(PTF):$$GETDATE^ICDGTDRG(PTF),1:DT)
- S DGNUM=$S($D(DGZDIAG)!($D(DGZPRO))!($D(DGZSER))!($D(DGZSUR)!(+DGZPRF-1'=$P(DGZPRF,U,3))):"MAS",1:"701") G MAS^DGPTFJC:DGST F X=$Y:1:(IOSL-9) W !
- W !! S Z="Patient Movements:" W Z S Z=" "_$S(DGPTFE:"M=Add PM X=Delete PM",1:"M=Edit Treat Spec/PM ")_" A=Add Code D=Delete Code V=Edit Mov" W Z
- W ! S Z="Surgical Episodes:" W Z S Z=" S=Add SE Z=Delete SE O=Add Code C=Delete Code J=Edit SE" W Z
- W ! S Z="Procedure Records:" W Z S Z=" T=Add PR R=Delete PR P=Add Code Q=Delete Code E=Edit PR" W Z
- W ! S Z=" 801:" W Z S Z=" I=Add 801 Y=Delete 801 N=Add CPT G=Delete CPT F=Edit 801" W Z K Z
- W !," ^=Abort <RET> to Continue:<",DGNUM,">// " R ANS:DTIME K DGNUM
- A S Z="^C Delete Code^A Add Code^O Add Code^P Add NOP^S Add SE^D Delete Code^M Add PM^X Delete PM^Z Delete SE^J Edit SE^Q Delete NOP^V Edit Move^"
- S Z=Z_"T Add PR^R Delete PR^E Edit PR^I Add 801^Y Delete 801^N Add CPT^G Delete CPT^F Edit 801"
- I 'DGPTFE S $P(Z,U,8,9)="M Edit treat Spec/PM"
- S X=ANS G Q^DGPTF:ANS="^" G ^DGPTFJ:ANS?1"^".E S (A,X)=ANS,X=$E(X,1) D IN^DGHELP
- I $P(^DGPT(PTF,0),U,4),X'="","IYNGF"[X W !,"***WARNING: This is a Community Care PTF record*** 801 encounters are not allowed." H 3 G DGPTFM ; DG*5.3*1057
- I ANS="" S (ST,ST1)=J+1 D:$D(DGZSUR) WR G @($S($D(DGZDIAG):"NDG",$D(DGZSER):"NSR",$D(DGZPRO):"NPR",$D(DGZSUR):"EN^DGPTFM0",+DGZPRF-1'=$P(DGZPRF,U,3):"NPS",1:"DONE"))
- G HELP^DGPTFM1A:$G(%)=-1 S Z=$L(A)-1 G @(X_$S(X="X":"",1:"^DGPTFM1"))
- PRV I $D(^VA(200,L,0)) W $P(^(0),U) Q
- W L Q
- X ;
- I 'Z S:PM=1 RC=1 G X1:PM=1 W !!,"Delete Patient move <1",$S(PM<3:"",1:"-"_(PM-1)),">: " R RC:DTIME G ^DGPTFM:RC["^"!(RC="")
- E S RC=$E(A,2,99) W !
- I +RC'=RC!('$D(M(RC))) W !!,"Enter the record # to delete from the PTF file, 1",$S(PM<3:"",1:"-"_(PM-1)) S Z=0 G X
- X1 I +M(RC)=1 W !,*7,"Cannot delete discharge movement",! H 3 G ^DGPTFM
- S DIE="^DGPT("_PTF_",""M"",",DP=45.02,DR=".01///@",DA(1)=PTF,DA=+M(RC) D ^DIE K DR W " ",RC,"-DELETED***" H 2 G ^DGPTFM
- Z ;
- W @DGVI,Z,@DGVO Q ; Writes reverse video
- EN D WR G EN^DGPTFM0
- 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[HDGPTFM 9354 printed Feb 19, 2025@00:18:17 Page 2
- DGPTFM ;ALB/MTC/PLT - PTF OP-PRO-DIAG ;07/01/2015 8:03 AM
- +1 ;;5.3;Registration;**510,517,590,594,606,635,683,696,664,850,884,1057**;Aug 13, 1993;Build 17
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 KILL X1,M,S,P,M1,M2,M3,S1,S2,PS2,P1,P2,P1P,P2P,SDCLY,^TMP("PTF",$JOB)
- +5 NEW EFFDATE,IMPDATE,DGMOVCNT,DGSURCNT,DGPROCNT,DGMMORE,DGPMORE
- +6 DO EFFDATE^DGPTIC10(PTF)
- +7 SET DGMOVCNT=0
- SET DGSURCNT=0
- SET DGPROCNT=0
- +8 SET I=0
- FOR I1=1:1
- SET I=$ORDER(^DGPT(PTF,"M",I))
- if 'I
- QUIT
- SET DGMOVCNT=$GET(DGMOVCNT)+1
- +9 SET I=0
- FOR I1=1:1
- SET I=$ORDER(^DGPT(PTF,"S",I))
- if 'I
- QUIT
- SET DGSURCNT=$GET(DGSURCNT)+1
- +10 SET I=0
- FOR I1=1:1
- SET I=$ORDER(^DGPT(PTF,"P",I))
- if 'I
- QUIT
- SET DGPROCNT=$GET(DGPROCNT)+1
- +11 SET I=0
- FOR I1=1:1:5
- SET I=$PIECE($GET(^DGPT(PTF,"401P")),U,I1)
- IF +I
- SET DGPRCNT=$GET(DGPRCNT)+1
- +12 SET DGMMORE=$GET(DGSURCNT)+$GET(DGPROCNT)+$GET(DGPRCNT)
- +13 SET DGPMORE=$GET(DGPROCNT)+$GET(DGPRCNT)
- +14 ;
- GET ;set m,m3 local array of movement records
- +1 SET I=0
- FOR I1=1:1
- SET I=$ORDER(^DGPT(PTF,"M",I))
- if 'I
- QUIT
- Begin DoDot:1
- +2 ;,M(I1,82)=$G(^DGPT(PTF,"M",I,82))
- SET M(I1)=^(I,0)
- SET M3(+M(I1))=M(I1)
- +3 IF $DATA(^DGPT(PTF,"M",I,"P"))
- SET $PIECE(M(I1),U,20)=^("P")
- +4 QUIT
- End DoDot:1
- +5 ;sort m array in chronological order for display, not m3
- +6 KILL MT
- DO ORDER^DGPTF
- KILL MT
- +7 DO GETVAR^DGPTFM6
- DO CL^SDCO21(DFN,$PIECE(^DGPT(PTF,0),U,2),"",.SDCLY)
- DO MOB^DGPTFM2
- +8 SET DGPC=I1-1
- +9 ; creates header
- DO WR
- +10 KILL M1,M2,^UTILITY($JOB)
- +11 SET ST=1
- SET M2=0
- DIAG ;
- +1 KILL DGZSER,DGZPRO,DGZSUR
- SET DGZDIAG=1
- +2 if $Y>16
- GOTO PRO1
- WRITE !
- +3 FOR J=ST:1:PM
- SET NL=1
- SET L5=0
- SET L6=J
- DO WD2
- DO WD
- if $Y>16
- GOTO PRO1
- DO WD3^DGPTFM8
- WRITE !
- +4 SET ST=1
- GOTO SER
- WD ;
- +1 NEW DGMPOA
- +2 DO EFFDATE^DGPTIC10(PTF)
- +3 WRITE !?2,"Movement Diagnosis: ",$$GETLABEL^DGPTIC10(DGPTDAT,"D")
- +4 ;F J1=1:1:11 I J1'=6 S L=$P(M(J),U,J1+4),L1=0,L3=1 I +L D
- +5 DO PTFICD^DGPTFUT(501,PTF,+M(J),.DGX501)
- +6 SET J1=0
- FOR
- SET J1=$ORDER(DGX501(J1))
- if 'J1
- QUIT
- SET L=DGX501(J1)
- SET L1=0
- SET L3=1
- IF +L
- Begin DoDot:1
- +7 SET DGMPOA=$PIECE(L,U,2)
- +8 if +L
- DO WD1
- +9 QUIT
- End DoDot:1
- +10 KILL DGX501
- +11 QUIT
- WD1 ;
- +1 SET N=$$ICDDATA^ICDXCODE("DIAG",+L,EFFDATE)
- SET M2=M2+1
- +2 WRITE !,?L1,$JUSTIFY(M2,3)," "
- +3 DO WRITECOD^DGPTIC10("DIAG",+L,EFFDATE,1,0,0)
- +4 IF $PIECE(N,U,20)=30
- if $X>73
- WRITE !," "
- WRITE " (POA=",$SELECT(DGMPOA]"":DGMPOA,1:"''"),")"
- +5 WRITE $SELECT(+N<1!('$PIECE(N,U,10)):"*",1:"")
- +6 KILL ^UTILITY($JOB,"M2",M2)
- SET ^UTILITY($JOB,"M2",M2)=+M(J+L1)_U_J1_U_(+L)_U_DGMPOA
- +7 IF $Y>(IOSL-4)
- DO PGBR
- WRITE @IOF,HEAD,?70
- SET Z="<MAS>"
- DO Z
- WRITE !
- +8 QUIT
- WD2 ;
- +1 NEW Z3
- +2 WRITE !?L5,"Move #",+L6
- SET Z=M(L6)
- SET Z3=M3(+Z)
- if +Z=1
- WRITE " D/C"
- SET Y=$PIECE(Z,U,10)\1
- DO D^DGPTUTL
- WRITE " ",Y," "
- +3 WRITE " <",$SELECT($PIECE(Z3,U,18)=1:"",1:"N"),"SC"_$SELECT($PIECE(Z3,U,26)="Y":",AO",1:"")_$SELECT($PIECE(Z3,U,27)="Y":",IR",1:"")_$SELECT($PIECE(Z3,U,28)="Y":",SWAC",1:"")_$SELECT($PIECE(Z3,U,32)="Y":",SHAD",1:"")_">"
- +4 IF $DATA(^DIC(42.4,+$PIECE(Z,U,2),0))
- Begin DoDot:1
- +5 IF $PIECE(^DIC(42.4,+$PIECE(Z,U,2),0),U,2)'=""
- WRITE $EXTRACT($PIECE(^DIC(42.4,+$PIECE(Z,U,2),0),U,2),1,10)
- +6 ;^(0) references global in line above
- IF '$TEST
- WRITE $EXTRACT($PIECE(^(0),U,1),1,10)
- +7 QUIT
- End DoDot:1
- +8 QUIT
- +9 ;
- NDG ;,M(I1,82)=$G(^DGPT(PTF,"M",I,82))
- DO WR
- SET I=0
- KILL M,M1,M2
- SET M2=0
- FOR I1=1:1
- SET I=$ORDER(^DGPT(PTF,"M",I))
- if I'>0
- QUIT
- SET M(I1)=^(I,0)
- +1 ;sort m array in chronological order for display
- +2 SET PM=I1-1
- DO ORDER^DGPTF
- KILL MT
- if $DATA(ST)
- GOTO DIAG
- GOTO GET
- SET ST=1
- +3 ;
- SER ;
- +1 KILL DGZDIAG,DGZPRO,DGZSUR
- +2 SET DGZSER=1
- +3 ;G PRO1:$Y>19
- +4 KILL S1,S2
- +5 SET S2=0
- if ST
- GOTO SERV
- GOTO PRO
- +6 ;
- SERV ;
- +1 ;F J=ST:2:SU S NL=1,L5=0,L6=J D SD2 S L5=1,L6=J+1 D:$D(S(L6)) SD2 D SD G PRO1:$Y>11 D SD3^DGPTFM8 G PRO1:$Y>11 W !
- +2 FOR J=ST:1:SU
- SET NL=1
- SET L5=0
- SET L6=J
- DO SD2
- DO SD
- DO SD3^DGPTFM8
- if (J<SU)
- if $Y>12
- GOTO PRO1
- WRITE !
- +3 KILL DGZSER
- +4 GOTO PRC^DGPTFM0
- SD ;
- +1 ;F J1=1:1:5 S L=$P(S(J),U,J1+7),L1=0,L3=1 D:+L SD1
- +2 DO PTFICD^DGPTFUT(401,PTF,S(J,1),.DGX401)
- +3 SET J1=0
- FOR
- SET J1=$ORDER(DGX401(J1))
- if 'J1
- QUIT
- SET L=DGX401(J1)
- SET L1=0
- SET L3=1
- if +L
- DO SD1
- +4 KILL DGX401
- +5 QUIT
- SD1 ;
- +1 SET N=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE)
- +2 SET S2=S2+1
- +3 WRITE !,?L1,$JUSTIFY(S2,3)," "
- DO WRITECOD^DGPTIC10("PROC",+L,EFFDATE,1,0,0)
- WRITE $SELECT(+N<1!('$PIECE(N,U,10)):"*",1:"")
- +4 KILL S2(S2)
- SET S2(S2)=J+L1_U_J1_U_(+L)
- +5 IF $Y>(IOSL-4)
- DO PGBR
- WRITE @IOF,HEAD,?70
- SET Z="<MAS>"
- DO Z
- WRITE !
- +6 QUIT
- +7 ;
- SD2 ;
- +1 SET Y=+S(L6)
- DO D^DGPTUTL
- WRITE !?L5,L6,"-Surgery date: ",Y,$$GETLABEL^DGPTIC10(EFFDATE,"P")
- +2 QUIT
- NSR KILL S,S1,S2
- SET I=0
- FOR I1=1:1
- SET I=$ORDER(^DGPT(PTF,"S",I))
- if I'>0
- QUIT
- SET S(I1)=^(I,0)
- SET S(I1,1)=I
- +1 SET S2=0
- SET SU=I1-1
- DO WR
- GOTO SERV
- +2 ;
- WR WRITE @IOF,HEAD,?70
- SET Z="<MAS>"
- DO Z
- +1 ; DG*5.3*1057
- WRITE !,?30,"Initial Date Of Service: ",$$EXTERNAL^DILFD(45,14,,$GET(DGIDTS))
- +2 QUIT
- PRO ;load 401p code before 2871000
- +1 KILL DGZSER,DGZDIAG,DGZSUR
- +2 SET DGZPRO=1
- +3 if $GET(DGPRCNT)
- if $Y>14
- GOTO PRO1
- +4 KILL P1P,P2P
- SET ST=1
- SET P2P=0
- +5 if '$DATA(PROC)
- GOTO NPR
- +6 ;
- PROC ; Display procedures in field 45.01 - 45.05
- +1 ;
- +2 ;D:$Y>14 WR
- if $Y>14
- GOTO PRO1
- +3 SET PROC=$SELECT($DATA(^DGPT(PTF,"401P")):^("401P"),1:"")
- +4 FOR PR=1:1:5
- SET DGPROC=$GET(DGPROC)_$PIECE(PROC,"^",PR)
- +5 KILL PR
- +6 if DGPROC]""
- WRITE !,"Procedures: ",$$GETLABEL^DGPTIC10(DGPTDAT,"P")
- +7 FOR J1=1:1:5
- SET L=$PIECE(PROC,"^",J1)
- IF L'=""
- SET P2P=P2P+1
- Begin DoDot:1
- +8 SET N=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE)
- +9 SET L2=$SELECT(N:$PIECE(N,U,2,99),1:"")
- +10 WRITE !,$JUSTIFY(P2P,3)," "
- DO WRITECOD^DGPTIC10("PROC",+L,EFFDATE,1,0,0)
- +11 WRITE $SELECT(+N<1!('$PIECE(N,U,10)):"*",1:"")
- +12 KILL P2P(P2P)
- SET P2P(P2P)=J1
- if $X>45
- WRITE !
- End DoDot:1
- +13 KILL DGZSER,DGZPRO,DGZDIAG,DGZSUR
- +14 ;
- ENC ;G PRO1:$Y>7,PRO1:'$P(DGZPRF,U,3)
- +1 if '$PIECE(DGZPRF,U,3)
- GOTO PRO1
- +2 if $Y>12
- GOTO PRO1
- +3 ;
- PF SET PS2=0
- SET J=+DGZPRF
- SET Y=+DGZPRF(J)
- SET DGSTRT=$SELECT(+$PIECE(DGZPRF,U,4):$PIECE(DGZPRF,U,4),1:4)
- SET DGLST=0
- +1 ; load SCI info and DGN's for this service date
- DO CL^SDCO21(DFN,+DGZPRF(J),"",.SDCLY)
- DO ICDINFO^DGAPI(DFN,PTF)
- DO XREF^DGPTFM21
- +2 DO D^DGPTUTL
- WRITE !,J,"-CPT Capture Date/Time: ",Y
- if ($PIECE(DGZPRF,U,2)-1!($GET(PGBRK)))
- WRITE " (cont.)"
- +3 IF $PIECE(DGZPRF(J),U,2)
- WRITE !,?5,"Referring or Ordering Provider: "
- SET L=$PIECE(DGZPRF(J),U,2)
- DO PRV
- +4 WRITE !,?5,"Rendering Provider: "
- SET L=$PIECE(DGZPRF(J),U,3)
- DO PRV
- +5 IF $PIECE(DGZPRF(J),U,5)
- WRITE !,?5,"Rendering Location: ",$PIECE($GET(^SC($PIECE(DGZPRF(J),U,5),0)),U)
- +6 SET (L1,PGBRK)=0
- +7 FOR K=$PIECE(DGZPRF,U,2):1
- if '$DATA(DGZPRF(J,K))
- QUIT
- IF '$GET(DGZPRF(J,K,9))
- SET PS2=PS2+1
- WRITE !,?2,PS2," "
- DO CPT^DGPTUTL1
- Begin DoDot:1
- +8 ; Add 801 logic
- +9 WRITE !,?4
- SET $PIECE(DS,"-",21)=""
- WRITE DS," Related Diagnosis",$$GETLABEL^DGPTIC10(+DGZPRF(J),"D")," ",DS
- +10 FOR L1=DGSTRT:1:11
- SET DGLOC=$SELECT(L1<8:L1,1:L1+7)
- SET CD=$PIECE(DGZPRF(J,K),U,DGLOC)
- IF CD
- Begin DoDot:2
- +11 ;,N=$S(N:$P(N,U,2,99),1:"")
- SET N=$$ICDDATA^ICDXCODE("DIAG",CD,+DGZPRF(J))
- +12 DO WRITECOD^DGPTIC10("DIAG",CD,+DGZPRF(J),2,1,8)
- +13 WRITE $SELECT(+N<1!('$PIECE(N,U,10)):"*",1:"")
- +14 DO CKSCI($PIECE(DGZPRF(J,K),U,DGLOC))
- End DoDot:2
- IF $Y+$GET(CKSCI)>16
- SET PGBRK=1
- QUIT
- +15 SET PS2(PS2)=J_U_K
- SET CD=1
- SET DGLOC=0
- SET DGSTRT=4
- End DoDot:1
- if $Y+$GET(DGZPRF(J,K+1,1))>16!($GET(PGBRK))
- QUIT
- +16 IF L1'=11
- IF $SELECT(L1<8:$PIECE($GET(DGZPRF(J,K)),U,L1+1,7),1:"")_$PIECE($GET(DGZPRF(J,K)),U,$SELECT(L1<8:15,1:L1+8),18)?."^"
- SET L1=11
- +17 IF L1=11
- SET $PIECE(DGZPRF,U,1,2)=$SELECT($DATA(DGZPRF(J,K+1)):J_U_(K+1),1:J+1_U_1)
- SET $PIECE(DGZPRF,U,4)=""
- SET PGBRK=0
- +18 IF '$TEST
- SET $PIECE(DGZPRF,U,1,2)=J_U_K
- SET $PIECE(DGZPRF,U,4)=L1+1
- +19 KILL I,K,L,L1,CD,N,DS
- GOTO PRO1
- +20 ;
- CKSCI(IEN) ;print SCI for each Diagnosis code
- +1 NEW DGINFO
- if '$DATA(XREF(IEN))
- QUIT
- +2 SET DGINFO=$GET(^DGICD9(46.1,(XREF(IEN)),0))
- SET CKSCI=0
- +3 IF 'DGINFO
- QUIT
- +4 FOR I=3,7,1,2,4,5,6,8
- IF $DATA(SDCLY(I))
- SET L=$SELECT(I=3:8,I<4:8+I,1:7+I)
- Begin DoDot:1
- +5 WRITE ?45
- SET M=1
- SET CKSCI=CKSCI+1
- +6 WRITE !?8
- +7 WRITE $PIECE("Treated for AO Condition^Treated for IR Condition^Treated for SC Condition^Exposed to SW Asia Conditions^Treatment for MST^Treatment for Head/Neck CA^Related to Combat^Treatment for SHAD Condition",U,I)
- +8 WRITE ": ",$SELECT($PIECE(DGINFO,U,($SELECT(I<3:I+2,I=3:2,1:I+1))):"YES",1:"NO"),!
- End DoDot:1
- +9 ;CKSCI
- QUIT
- +10 ;
- NPR SET ST=1
- SET PROC=$SELECT($DATA(^DGPT(PTF,"401P")):^("401P"),1:"")
- DO WR
- GOTO PRO
- +1 ;
- NPS DO WR
- GOTO PF
- +1 ;
- DONE GOTO EN1^DGPTF4
- PRO1 ;SET MENU TYPE AND DISPLAY MENU
- +1 NEW ICDVDT,ICPTVDT
- +2 IF $GET(PTF)'=""
- IF $GET(EFFDATE)=""
- DO EFFDATE^DGPTIC10(PTF)
- +3 SET (ICDVDT,ICPTVDT)=$SELECT($GET(EFFDATE)'="":EFFDATE,$DATA(PTF):$$GETDATE^ICDGTDRG(PTF),1:DT)
- +4 SET DGNUM=$SELECT($DATA(DGZDIAG)!($DATA(DGZPRO))!($DATA(DGZSER))!($DATA(DGZSUR)!(+DGZPRF-1'=$PIECE(DGZPRF,U,3))):"MAS",1:"701")
- if DGST
- GOTO MAS^DGPTFJC
- FOR X=$Y:1:(IOSL-9)
- WRITE !
- +5 WRITE !!
- SET Z="Patient Movements:"
- WRITE Z
- SET Z=" "_$SELECT(DGPTFE:"M=Add PM X=Delete PM",1:"M=Edit Treat Spec/PM ")_" A=Add Code D=Delete Code V=Edit Mov"
- WRITE Z
- +6 WRITE !
- SET Z="Surgical Episodes:"
- WRITE Z
- SET Z=" S=Add SE Z=Delete SE O=Add Code C=Delete Code J=Edit SE"
- WRITE Z
- +7 WRITE !
- SET Z="Procedure Records:"
- WRITE Z
- SET Z=" T=Add PR R=Delete PR P=Add Code Q=Delete Code E=Edit PR"
- WRITE Z
- +8 WRITE !
- SET Z=" 801:"
- WRITE Z
- SET Z=" I=Add 801 Y=Delete 801 N=Add CPT G=Delete CPT F=Edit 801"
- WRITE Z
- KILL Z
- +9 WRITE !," ^=Abort <RET> to Continue:<",DGNUM,">// "
- READ ANS:DTIME
- KILL DGNUM
- A SET Z="^C Delete Code^A Add Code^O Add Code^P Add NOP^S Add SE^D Delete Code^M Add PM^X Delete PM^Z Delete SE^J Edit SE^Q Delete NOP^V Edit Move^"
- +1 SET Z=Z_"T Add PR^R Delete PR^E Edit PR^I Add 801^Y Delete 801^N Add CPT^G Delete CPT^F Edit 801"
- +2 IF 'DGPTFE
- SET $PIECE(Z,U,8,9)="M Edit treat Spec/PM"
- +3 SET X=ANS
- if ANS="^"
- GOTO Q^DGPTF
- if ANS?1"^".E
- GOTO ^DGPTFJ
- SET (A,X)=ANS
- SET X=$EXTRACT(X,1)
- DO IN^DGHELP
- +4 ; DG*5.3*1057
- IF $PIECE(^DGPT(PTF,0),U,4)
- IF X'=""
- IF "IYNGF"[X
- WRITE !,"***WARNING: This is a Community Care PTF record*** 801 encounters are not allowed."
- HANG 3
- GOTO DGPTFM
- +5 IF ANS=""
- SET (ST,ST1)=J+1
- if $DATA(DGZSUR)
- DO WR
- GOTO @($SELECT($DATA(DGZDIAG):"NDG",$DATA(DGZSER):"NSR",$DATA(DGZPRO):"NPR",$DATA(DGZSUR):"EN^DGPTFM0",+DGZPRF-1'=$PIECE(DGZPRF,U,3):"NPS",1:"DONE"))
- +6 if $GET(%)=-1
- GOTO HELP^DGPTFM1A
- SET Z=$LENGTH(A)-1
- GOTO @(X_$SELECT(X="X":"",1:"^DGPTFM1"))
- PRV IF $DATA(^VA(200,L,0))
- WRITE $PIECE(^(0),U)
- QUIT
- +1 WRITE L
- QUIT
- X ;
- +1 IF 'Z
- if PM=1
- SET RC=1
- if PM=1
- GOTO X1
- WRITE !!,"Delete Patient move <1",$SELECT(PM<3:"",1:"-"_(PM-1)),">: "
- READ RC:DTIME
- if RC["^"!(RC="")
- GOTO ^DGPTFM
- +2 IF '$TEST
- SET RC=$EXTRACT(A,2,99)
- WRITE !
- +3 IF +RC'=RC!('$DATA(M(RC)))
- WRITE !!,"Enter the record # to delete from the PTF file, 1",$SELECT(PM<3:"",1:"-"_(PM-1))
- SET Z=0
- GOTO X
- X1 IF +M(RC)=1
- WRITE !,*7,"Cannot delete discharge movement",!
- HANG 3
- GOTO ^DGPTFM
- +1 SET DIE="^DGPT("_PTF_",""M"","
- SET DP=45.02
- SET DR=".01///@"
- SET DA(1)=PTF
- SET DA=+M(RC)
- DO ^DIE
- KILL DR
- WRITE " ",RC,"-DELETED***"
- HANG 2
- GOTO ^DGPTFM
- Z ;
- +1 ; Writes reverse video
- WRITE @DGVI,Z,@DGVO
- QUIT
- EN DO WR
- GOTO EN^DGPTFM0
- +1 QUIT
- +2 ;
- PGBR NEW DIR,X,Y
- SET DIR(0)="E"
- SET DIR("A")="Enter RETURN to continue"
- DO ^DIR
- QUIT
- +1 ;