DGPTFM4 ;ALB/MTC/ADL - PTF ENTRY/EDIT-2 ; 12/18/07 11:37am
;;5.3;PIMS;**114,195,397,510,565,775,664,1015,1016**;JUN 30, 2012;Build 20
;;ADL;Update for CSV Project;;Mar 26, 2003
;
S DGZM0=DGZM0+1
EN N M3 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:"")
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
; added 6/17/98 for MST enhancement
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
W !! S Z=2 D Z W " DX: " F I=1:1:11 S L=$P(M1,U,I+4) I L'=""&(I'=6) S DGPTTMP=$$ICDDX^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF)) D
. W $S(+DGPTTMP>0:$P(DGPTTMP,U,4)_" ("_$P(DGPTTMP,U,2)_")",1:"**********-"_L),!?17
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) S DR="[DG501"_$E("F",DGPTFE) X:(+M(DGZM0)=1) "S J=^DGPT(PTF,""M"",1,0) F I=11:1:15 I $P(J,U,I) S DR=DR_1" S DR=DR_"]",DGJUMP=X,DIE="^DGPT(",(DA,DGPTF)=PTF,DGMOV=+M(DGZM0) D ^DIE 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)
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 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
DGPTFM4 ;ALB/MTC/ADL - PTF ENTRY/EDIT-2 ; 12/18/07 11:37am
+1 ;;5.3;PIMS;**114,195,397,510,565,775,664,1015,1016**;JUN 30, 2012;Build 20
+2 ;;ADL;Update for CSV Project;;Mar 26, 2003
+3 ;
+4 SET DGZM0=DGZM0+1
EN NEW M3
IF '$DATA(M)
DO MOB
SET M(DGZM0)=$SELECT($DATA(M(DGZM0)):M(DGZM0),1:"")
IF M(DGZM0)=""
GOTO NEXM
SET (M3,M(DGZM0),M1)=$SELECT($DATA(^DGPT(PTF,"M",+M(DGZM0),0)):^DGPT(PTF,"M",+M(DGZM0),0),1:"")
+1 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 ; added 6/17/98 for MST enhancement
+9 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
+10 KILL DGNTARR
+11 SET DGNTARR=$$GETCUR^DGNTAPI(DFN,"DGNTARR")
+12 IF $PIECE(M3,U,30)=""
IF (",3,4,5,"[(","_$PIECE($GET(DGNTARR("STAT")),U)_","))
SET $PIECE(M3,U,30)="N"
+13 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
+14 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")
+15 KILL NL
+16 WRITE !!
SET Z=2
DO Z
WRITE " DX: "
FOR I=1:1:11
SET L=$PIECE(M1,U,I+4)
IF L'=""&(I'=6)
SET DGPTTMP=$$ICDDX^ICDCODE(+L,$$GETDATE^ICDGTDRG(PTF))
Begin DoDot:1
+17 WRITE $SELECT(+DGPTTMP>0:$PIECE(DGPTTMP,U,4)_" ("_$PIECE(DGPTTMP,U,2)_")",1:"**********-"_L),!?17
End DoDot:1
+18 IF DG300]""
DO PRN2^DGPTFM8
+19 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
+20 NEW DXD,DGDX
+21 SET DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,$PIECE(M1,U,10))
SET DGDS=0
+22 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!(X[2)
SET DR="[DG501"_$EXTRACT("F",DGPTFE)
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_1"
SET DR=DR_"]"
SET DGJUMP=X
SET DIE="^DGPT("
SET (DA,DGPTF)=PTF
SET DGMOV=+M(DGZM0)
DO ^DIE
KILL M,DR,DIE
DO CHK501^DGPTSCAN
KILL DGPTF,DGMOV
+1 ; Determine if NTR HISTORY (#28.11) filer is called if question for
+2 ; 'Treated for Head/Neck CA Condition:' is answered YES.
+3 ; Only a NTR screening status of 3=PENDING DIAGNOSIS gets Filed.
+4 IF $PIECE($GET(M3),U,30)="Y"
IF $PIECE($GET(DGNTARR("STAT")),U)=3
Begin DoDot:1
+5 SET DGNTARR=$$FILEHNC^DGNTAPI1(DFN)
End DoDot:1
+6 KILL DGNTARR
+7 ;- update MT indicator after edit movement
+8 NEW DGPMCA,DGPMAN
DO PM^DGPTUTL
+9 IF '$GET(DGADM)
SET DGADM=+^DGPT(PTF,0)
+10 DO MT^DGPTUTL
+11 GOTO EN
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
ADD 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
+1 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
+2 SET M(DGZM0)=L1+I
SET X="1-2"
GOTO X1
+3 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
