DGPTFM4 ;ALB/MTC/ADL/PLT - PTF ENTRY/EDIT-2 ;12/18/07 11:37am
;;5.3;Registration;**114,195,397,510,565,775,664,759,850,884**;Aug 13, 1993;Build 31
;;Per VA Directive 6402, this routine should not be modified.
;
;;ADL;Update for CSV Project;;Mar 26, 2003
;
S DGZM0=DGZM0+1
EN ;
N M3,M82,DGMPOA
D MOB:'$D(M)
S M(DGZM0)=$S($D(M(DGZM0)):M(DGZM0),1:"") G NEXM:M(DGZM0)=""
S (M3,M(DGZM0),M1)=$S($D(^DGPT(PTF,"M",+M(DGZM0),0)):^DGPT(PTF,"M",+M(DGZM0),0),1:"")
S M82=$G(^DGPT(PTF,"M",+M(DGZM0),82))
I $D(^DGPT(PTF,"M",+M(DGZM0),"P")) S $P(M(DGZM0),U,20)=^("P"),$P(M1,U,20)=^("P")
WR S DG300=$S($D(^DGPT(PTF,"M",+M(DGZM0),300)):^(300),1:"")
W @IOF,HEAD,?70 S Z="<501-"_DGZM0_">" D Z^DGPTFM I +M(DGZM0)=1 W !,?62,"Discharge Movement"
M S L=+$P(M1,U,10),Y=L D D^DGPTUTL W !! S Z=1 D Z W "Date of Move: " S Z=Y,Z1=20 D Z1 W "Losing Specialty: ",$E($S($D(^DIC(42.4,+$P(M1,U,2),0)):$P(^(0),U,1),1:""),1,25)
W !," Leave days: ",$P(M1,U,3),?44,"Pass days: ",$P(M1,U,4)
W !,"Treated for SC Condition: ",$S($P(M3,U,18)=1:"Yes",1:"No")
N NL S NL=0
I $P(M3,U,31)'="" W @($S(NL#2:"!",1:"?37")),"Potentially Related to Combat: ",$S($P(M3,U,31)="Y":"Yes",1:"No") S NL=NL+1
I $P(M3,U,26)'="" W @($S(NL#2:"!",1:"?37")),"Treated for AO Condition: ",$S($P(M3,U,26)="Y":"Yes",1:"No") S NL=NL+1
I $P(M3,U,27)'="" W @($S(NL#2:"!",1:"?37")),"Treated for IR Condition: ",$S($P(M3,U,27)="Y":"Yes",1:"No") S NL=NL+1
I $P(M3,U,28)'="" W @($S(NL#2:"!",1:"?37")),"Treated for service in SW Asia: ",$S($P(M3,U,28)="Y":"Yes",1:"No") S NL=NL+1
I $P(M3,U,29)'="" W @($S(NL#2:"!",1:"?37")),"Treated for MST Condition: ",$S($P(M3,U,29)="Y":"Yes",1:"No") S NL=NL+1
K DGNTARR
S DGNTARR=$$GETCUR^DGNTAPI(DFN,"DGNTARR")
I $P(M3,U,30)="",(",3,4,5,"[(","_$P($G(DGNTARR("STAT")),U)_",")) S $P(M3,U,30)="N"
I $P(M3,U,30)'="" W @($S(NL#2:"!",1:"?37")),"Treated for HEAD/NECK CA Condition: ",$S($P(M3,U,30)="Y":"Yes",1:"No") S NL=NL+1
I $P(M3,U,32)'="" W @($S(NL#2:"!",1:"?37")),"Treated for Project 112/SHAD: ",$S($P(M3,U,32)="Y":"Yes",1:"No")
K NL
N EFFDATE,IMPDATE
D EFFDATE^DGPTIC10(PTF)
W !! S Z=2 D Z W " DX: ",$$GETLABEL^DGPTIC10(EFFDATE,"D")
;F I=1:1:11 S L=$P(M1,U,I+4) I L'=""&(I'=6) D
D PTFICD^DGPTFUT(501,PTF,+M(DGZM0),.DGX501)
S I=0 F S I=$O(DGX501(I)) QUIT:'I S L=DGX501(I) D
. S DGMPOA=$P(L,U,2)
. S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+L,EFFDATE)
. D WRITECOD^DGPTIC10("DIAG",+L,EFFDATE,2,1,15)
. I $P(DGPTTMP,U,20)=30 W:$X>73 !," " W " (POA=",$S(DGMPOA]"":DGMPOA,1:"''"),")"
. W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
. I $Y>(IOSL-4) D PGBR W @IOF,HEAD,?72 S Z="<501-"_DGZM0_">" D Z^DGPTFM W !
. QUIT
K DGX501
D PRN2^DGPTFM8:DG300]""
;
I $P(M1,U,20) S DRG=$P(M1,U,20) W:DRG=998!(DRG=999)!((DRG=468!(DRG=469)!(DRG=470))&(+$P($G(M1),U,10)<3071001)) *7 W !!?14,"TRANSFER DRG: ",DRG D
. N DXD,DGDX
. S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,$P(M1,U,10)),DGDS=0
. F S DGDS=$O(DGDX(DGDS)) Q:'+DGDS Q:DGDX(DGDS)=" " W !,DGDX(DGDS)
JUMP K DG300 F I=$Y:1:21 W !
X S DGNUM=$S($D(M(DGZM0+1)):501_"-"_(DGZM0+1),1:"MAS") G 501^DGPTFJC:DGST
W "Enter <RET> to continue, 1-2 to edit,",!,"'M' ",$S(DGPTFE:" to add a patient movement",1:"to edit Treat. Specialty"),", '^N' for screen N, or '^' to abort:<",DGNUM,">// " R X:DTIME
K DGNUM G Q:X="^",NEXM:X="",^DGPTFJ:X?1"^".E,M^DGPTFM1:X="M"!(X="m")
X1 I X'=1,X'=2,X'="1-2" G PR
S DGCODSYS=$$CODESYS^DGPTIC10(PTF)
S DR=$S(DGPTFE:"[DG501F-10D]",1:"[DG501-10D]") I DGCODSYS="ICD9" S DR=$S(DGPTFE:"[DG501F]",1:"[DG501]")
S DGJUMP=X,DIE="^DGPT(",(DA,DGPTF)=PTF,DGMOV=+M(DGZM0) D ^DIE
I DR'["-10D" K DR,DA,DIE,DIC S DR="" X:(+M(DGZM0)=1) "S J=^DGPT(PTF,""M"",1,0) F I=11:1:15 I $P(J,U,I) S DR=DR_I_"";""" I DR'="" D
. S DGJUMP=X,DIE="^DGPT("_DGPTF_",""M"",",(DA(1),DGPTF)=PTF,(DA,DGMOV)=+M(DGZM0)
. D ^DIE
. QUIT
K M,DR,DIE D CHK501^DGPTSCAN K DGPTF,DGMOV
; Determine if NTR HISTORY (#28.11) filer is called if question for
; 'Treated for Head/Neck CA Condition:' is answered YES.
; Only a NTR screening status of 3=PENDING DIAGNOSIS gets Filed.
I $P($G(M3),U,30)="Y",$P($G(DGNTARR("STAT")),U)=3 D
. S DGNTARR=$$FILEHNC^DGNTAPI1(DFN)
. QUIT
K DGNTARR
;- update MT indicator after edit movement
N DGPMCA,DGPMAN D PM^DGPTUTL
I '$G(DGADM) S DGADM=+^DGPT(PTF,0)
D MT^DGPTUTL
G EN
;
PR W !,"Enter '^' to stop the display and edit of data",!,"'^N' to jump to screen #N (appears in upper right of screen '<N>'",!,"<RET> to continue on to the next screen or 1-2 to edit:"
W !?10,"1-",$S(DGPTFE:"Date of movement, Losing Specialty, ",1:""),"Leave and Pass days",!?10,"2-ICD DIAGNOSIS CODES"
W !,"You may also enter 1-2",!
R !!,"Enter <RET>: ",X:DTIME G WR
Q
NEXM S DGZM0=DGZM0+1 G ^DGPTFM:'$D(M(DGZM0)),EN
;
ADD ;add movement record of fee basis patent
S DGZM0=$S($D(DGZM0):DGZM0+1,1:0) S L=$S($D(^DGPT(PTF,"M",0)):^(0),1:"^45.02DA^^"),L1=$P(L,U,3) F I=1:1 Q:'$D(^DGPT(PTF,"M",L1+I))
S DA(1)=PTF,DIC="^DGPT("_DA(1)_",""M"",",X=L1+I,DIC(0)="LMZQE" D ^DIC K DIC,DIE G ^DGPTFM:Y'>0
S M(DGZM0)=L1+I S X="1-2" G X1
Q
MOB S I=0 K M,M1,M2 S M2=0 F I1=1:1 S I=$O(^DGPT(PTF,"M",I)) Q:'I S M(I1)=^(I,0)
S PM=I1-1 D ORDER^DGPTF Q
Q G Q^DGPTF
Z I 'DGN S Z=$S(IOST="C-QUME"&($L(DGVI)'=2):Z,1:"["_Z_"]") W @DGVI,Z,@DGVO
E W " "
Q
Z1 F I=1:1:(Z1-$L(Z)) S Z=Z_" "
W Z
Q
R ;DELETE PROCEDURE RECORD
I '$D(^DGPT(PTF,"P")) G NOPROC
I $O(^DGPT(PTF,"P",0))']"" G NOPROC
S DGPNUM="" F DGPROC=0:0 S DGPROC=$O(P(DGPROC)) Q:'DGPROC S:$D(P(DGPROC,1)) DGPNUM=DGPNUM_","_DGPROC
S DGPNUM=DGPNUM_","
ASKPRO W !!,"Delete procedure record <",$P(DGPNUM,",",2,99),"> : " R DGPROC:DTIME I DGPROC[U!(DGPROC="") K DGPNUM,DGPROC G ^DGPTFM
I DGPNUM'[(","_DGPROC_",") W !!,"Enter the record # to delete from the PTF file <",$P(DGPNUM,",",2,99),">",! G ASKPRO
K DA N DGJ
F DGJ=1:1 S DA=+$P(DGPROC,",",DGJ) Q:'DA S DA=$S($D(P(DA,1)):+P(DA,1),1:0) I DA S DA(1)=PTF,DIK="^DGPT("_PTF_",""P""," D ^DIK K DA W " ",$P(DGPROC,",",DGJ),"-DELETED***" H:'$P(DGPROC,",",DGJ+1) 2
K DIK,DA,DGPROC,DGPNUM G ^DGPTFM
NOPROC W !!,*7,"No procedures to delete",! H 3 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[HDGPTFM4 6219 printed Apr 09, 2024@21:52:39 Page 2
DGPTFM4 ;ALB/MTC/ADL/PLT - PTF ENTRY/EDIT-2 ;12/18/07 11:37am
+1 ;;5.3;Registration;**114,195,397,510,565,775,664,759,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 26, 2003
+5 ;
+6 SET DGZM0=DGZM0+1
EN ;
+1 NEW M3,M82,DGMPOA
+2 if '$DATA(M)
DO MOB
+3 SET M(DGZM0)=$SELECT($DATA(M(DGZM0)):M(DGZM0),1:"")
if M(DGZM0)=""
GOTO NEXM
+4 SET (M3,M(DGZM0),M1)=$SELECT($DATA(^DGPT(PTF,"M",+M(DGZM0),0)):^DGPT(PTF,"M",+M(DGZM0),0),1:"")
+5 SET M82=$GET(^DGPT(PTF,"M",+M(DGZM0),82))
+6 IF $DATA(^DGPT(PTF,"M",+M(DGZM0),"P"))
SET $PIECE(M(DGZM0),U,20)=^("P")
SET $PIECE(M1,U,20)=^("P")
WR SET DG300=$SELECT($DATA(^DGPT(PTF,"M",+M(DGZM0),300)):^(300),1:"")
+1 WRITE @IOF,HEAD,?70
SET Z="<501-"_DGZM0_">"
DO Z^DGPTFM
IF +M(DGZM0)=1
WRITE !,?62,"Discharge Movement"
M SET L=+$PIECE(M1,U,10)
SET Y=L
DO D^DGPTUTL
WRITE !!
SET Z=1
DO Z
WRITE "Date of Move: "
SET Z=Y
SET Z1=20
DO Z1
WRITE "Losing Specialty: ",$EXTRACT($SELECT($DATA(^DIC(42.4,+$PIECE(M1,U,2),0)):$PIECE(^(0),U,1),1:""),1,25)
+1 WRITE !," Leave days: ",$PIECE(M1,U,3),?44,"Pass days: ",$PIECE(M1,U,4)
+2 WRITE !,"Treated for SC Condition: ",$SELECT($PIECE(M3,U,18)=1:"Yes",1:"No")
+3 NEW NL
SET NL=0
+4 IF $PIECE(M3,U,31)'=""
WRITE @($SELECT(NL#2:"!",1:"?37")),"Potentially Related to Combat: ",$SELECT($PIECE(M3,U,31)="Y":"Yes",1:"No")
SET NL=NL+1
+5 IF $PIECE(M3,U,26)'=""
WRITE @($SELECT(NL#2:"!",1:"?37")),"Treated for AO Condition: ",$SELECT($PIECE(M3,U,26)="Y":"Yes",1:"No")
SET NL=NL+1
+6 IF $PIECE(M3,U,27)'=""
WRITE @($SELECT(NL#2:"!",1:"?37")),"Treated for IR Condition: ",$SELECT($PIECE(M3,U,27)="Y":"Yes",1:"No")
SET NL=NL+1
+7 IF $PIECE(M3,U,28)'=""
WRITE @($SELECT(NL#2:"!",1:"?37")),"Treated for service in SW Asia: ",$SELECT($PIECE(M3,U,28)="Y":"Yes",1:"No")
SET NL=NL+1
+8 IF $PIECE(M3,U,29)'=""
WRITE @($SELECT(NL#2:"!",1:"?37")),"Treated for MST Condition: ",$SELECT($PIECE(M3,U,29)="Y":"Yes",1:"No")
SET NL=NL+1
+9 KILL DGNTARR
+10 SET DGNTARR=$$GETCUR^DGNTAPI(DFN,"DGNTARR")
+11 IF $PIECE(M3,U,30)=""
IF (",3,4,5,"[(","_$PIECE($GET(DGNTARR("STAT")),U)_","))
SET $PIECE(M3,U,30)="N"
+12 IF $PIECE(M3,U,30)'=""
WRITE @($SELECT(NL#2:"!",1:"?37")),"Treated for HEAD/NECK CA Condition: ",$SELECT($PIECE(M3,U,30)="Y":"Yes",1:"No")
SET NL=NL+1
+13 IF $PIECE(M3,U,32)'=""
WRITE @($SELECT(NL#2:"!",1:"?37")),"Treated for Project 112/SHAD: ",$SELECT($PIECE(M3,U,32)="Y":"Yes",1:"No")
+14 KILL NL
+15 NEW EFFDATE,IMPDATE
+16 DO EFFDATE^DGPTIC10(PTF)
+17 WRITE !!
SET Z=2
DO Z
WRITE " DX: ",$$GETLABEL^DGPTIC10(EFFDATE,"D")
+18 ;F I=1:1:11 S L=$P(M1,U,I+4) I L'=""&(I'=6) D
+19 DO PTFICD^DGPTFUT(501,PTF,+M(DGZM0),.DGX501)
+20 SET I=0
FOR
SET I=$ORDER(DGX501(I))
if 'I
QUIT
SET L=DGX501(I)
Begin DoDot:1
+21 SET DGMPOA=$PIECE(L,U,2)
+22 SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+L,EFFDATE)
+23 DO WRITECOD^DGPTIC10("DIAG",+L,EFFDATE,2,1,15)
+24 IF $PIECE(DGPTTMP,U,20)=30
if $X>73
WRITE !," "
WRITE " (POA=",$SELECT(DGMPOA]"":DGMPOA,1:"''"),")"
+25 WRITE $SELECT(+DGPTTMP<1!('$PIECE(DGPTTMP,U,10)):"*",1:"")
+26 IF $Y>(IOSL-4)
DO PGBR
WRITE @IOF,HEAD,?72
SET Z="<501-"_DGZM0_">"
DO Z^DGPTFM
WRITE !
+27 QUIT
End DoDot:1
+28 KILL DGX501
+29 if DG300]""
DO PRN2^DGPTFM8
+30 ;
+31 IF $PIECE(M1,U,20)
SET DRG=$PIECE(M1,U,20)
if DRG=998!(DRG=999)!((DRG=468!(DRG=469)!(DRG=470))&(+$PIECE($GET(M1),U,10)<3071001))
WRITE *7
WRITE !!?14,"TRANSFER DRG: ",DRG
Begin DoDot:1
+32 NEW DXD,DGDX
+33 SET DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,$PIECE(M1,U,10))
SET DGDS=0
+34 FOR
SET DGDS=$ORDER(DGDX(DGDS))
if '+DGDS
QUIT
if DGDX(DGDS)=" "
QUIT
WRITE !,DGDX(DGDS)
End DoDot:1
JUMP KILL DG300
FOR I=$Y:1:21
WRITE !
X SET DGNUM=$SELECT($DATA(M(DGZM0+1)):501_"-"_(DGZM0+1),1:"MAS")
if DGST
GOTO 501^DGPTFJC
+1 WRITE "Enter <RET> to continue, 1-2 to edit,",!,"'M' ",$SELECT(DGPTFE:" to add a patient movement",1:"to edit Treat. Specialty"),", '^N' for screen N, or '^' to abort:<",DGNUM,">// "
READ X:DTIME
+2 KILL DGNUM
if X="^"
GOTO Q
if X=""
GOTO NEXM
if X?1"^".E
GOTO ^DGPTFJ
if X="M"!(X="m")
GOTO M^DGPTFM1
X1 IF X'=1
IF X'=2
IF X'="1-2"
GOTO PR
+1 SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)
+2 SET DR=$SELECT(DGPTFE:"[DG501F-10D]",1:"[DG501-10D]")
IF DGCODSYS="ICD9"
SET DR=$SELECT(DGPTFE:"[DG501F]",1:"[DG501]")
+3 SET DGJUMP=X
SET DIE="^DGPT("
SET (DA,DGPTF)=PTF
SET DGMOV=+M(DGZM0)
DO ^DIE
+4 IF DR'["-10D"
KILL DR,DA,DIE,DIC
SET DR=""
if (+M(DGZM0)=1)
XECUTE "S J=^DGPT(PTF,""M"",1,0) F I=11:1:15 I $P(J,U,I) S DR=DR_I_"";"""
IF DR'=""
Begin DoDot:1
+5 SET DGJUMP=X
SET DIE="^DGPT("_DGPTF_",""M"","
SET (DA(1),DGPTF)=PTF
SET (DA,DGMOV)=+M(DGZM0)
+6 DO ^DIE
+7 QUIT
End DoDot:1
+8 KILL M,DR,DIE
DO CHK501^DGPTSCAN
KILL DGPTF,DGMOV
+9 ; Determine if NTR HISTORY (#28.11) filer is called if question for
+10 ; 'Treated for Head/Neck CA Condition:' is answered YES.
+11 ; Only a NTR screening status of 3=PENDING DIAGNOSIS gets Filed.
+12 IF $PIECE($GET(M3),U,30)="Y"
IF $PIECE($GET(DGNTARR("STAT")),U)=3
Begin DoDot:1
+13 SET DGNTARR=$$FILEHNC^DGNTAPI1(DFN)
+14 QUIT
End DoDot:1
+15 KILL DGNTARR
+16 ;- update MT indicator after edit movement
+17 NEW DGPMCA,DGPMAN
DO PM^DGPTUTL
+18 IF '$GET(DGADM)
SET DGADM=+^DGPT(PTF,0)
+19 DO MT^DGPTUTL
+20 GOTO EN
+21 ;
PR WRITE !,"Enter '^' to stop the display and edit of data",!,"'^N' to jump to screen #N (appears in upper right of screen '<N>'",!,"<RET> to continue on to the next screen or 1-2 to edit:"
+1 WRITE !?10,"1-",$SELECT(DGPTFE:"Date of movement, Losing Specialty, ",1:""),"Leave and Pass days",!?10,"2-ICD DIAGNOSIS CODES"
+2 WRITE !,"You may also enter 1-2",!
+3 READ !!,"Enter <RET>: ",X:DTIME
GOTO WR
+4 QUIT
NEXM SET DGZM0=DGZM0+1
if '$DATA(M(DGZM0))
GOTO ^DGPTFM
GOTO EN
+1 ;
ADD ;add movement record of fee basis patent
+1 SET DGZM0=$SELECT($DATA(DGZM0):DGZM0+1,1:0)
SET L=$SELECT($DATA(^DGPT(PTF,"M",0)):^(0),1:"^45.02DA^^")
SET L1=$PIECE(L,U,3)
FOR I=1:1
if '$DATA(^DGPT(PTF,"M",L1+I))
QUIT
+2 SET DA(1)=PTF
SET DIC="^DGPT("_DA(1)_",""M"","
SET X=L1+I
SET DIC(0)="LMZQE"
DO ^DIC
KILL DIC,DIE
if Y'>0
GOTO ^DGPTFM
+3 SET M(DGZM0)=L1+I
SET X="1-2"
GOTO X1
+4 QUIT
MOB SET I=0
KILL M,M1,M2
SET M2=0
FOR I1=1:1
SET I=$ORDER(^DGPT(PTF,"M",I))
if 'I
QUIT
SET M(I1)=^(I,0)
+1 SET PM=I1-1
DO ORDER^DGPTF
QUIT
Q GOTO Q^DGPTF
Z IF 'DGN
SET Z=$SELECT(IOST="C-QUME"&($LENGTH(DGVI)'=2):Z,1:"["_Z_"]")
WRITE @DGVI,Z,@DGVO
+1 IF '$TEST
WRITE " "
+2 QUIT
Z1 FOR I=1:1:(Z1-$LENGTH(Z))
SET Z=Z_" "
+1 WRITE Z
+2 QUIT
R ;DELETE PROCEDURE RECORD
+1 IF '$DATA(^DGPT(PTF,"P"))
GOTO NOPROC
+2 IF $ORDER(^DGPT(PTF,"P",0))']""
GOTO NOPROC
+3 SET DGPNUM=""
FOR DGPROC=0:0
SET DGPROC=$ORDER(P(DGPROC))
if 'DGPROC
QUIT
if $DATA(P(DGPROC,1))
SET DGPNUM=DGPNUM_","_DGPROC
+4 SET DGPNUM=DGPNUM_","
ASKPRO WRITE !!,"Delete procedure record <",$PIECE(DGPNUM,",",2,99),"> : "
READ DGPROC:DTIME
IF DGPROC[U!(DGPROC="")
KILL DGPNUM,DGPROC
GOTO ^DGPTFM
+1 IF DGPNUM'[(","_DGPROC_",")
WRITE !!,"Enter the record # to delete from the PTF file <",$PIECE(DGPNUM,",",2,99),">",!
GOTO ASKPRO
+2 KILL DA
NEW DGJ
+3 FOR DGJ=1:1
SET DA=+$PIECE(DGPROC,",",DGJ)
if 'DA
QUIT
SET DA=$SELECT($DATA(P(DA,1)):+P(DA,1),1:0)
IF DA
SET DA(1)=PTF
SET DIK="^DGPT("_PTF_",""P"","
DO ^DIK
KILL DA
WRITE " ",$PIECE(DGPROC,",",DGJ),"-DELETED***"
if '$PIECE(DGPROC,",",DGJ+1)
HANG 2
+4 KILL DIK,DA,DGPROC,DGPNUM
GOTO ^DGPTFM
NOPROC WRITE !!,*7,"No procedures to delete",!
HANG 3
GOTO ^DGPTFM
+1 QUIT
+2 ;
PGBR NEW DIR,X,Y
SET DIR(0)="E"
SET DIR("A")="Enter RETURN to continue"
DO ^DIR
QUIT
+1 ;
