DGPTF4 ;ALB/JDS/PLT - PTF ENTRY/EDIT-4 ;2/19/04 9:33am
;;5.3;Registration;**114,115,397,510,517,478,683,775,850,884,1057**;Aug 13, 1993;Build 17
;;Per VA Directive 6402, this routine should not be modified.
;
WR ;
W @IOF,HEAD,?72 S Z="<701>" D Z^DGPTFM W !,?30,"Initial Date Of Service: ",$$EXTERNAL^DILFD(45,14,,$G(DGIDTS)) K X S $P(X,"-",81)="" W !,X ; DG*5.3*1057
Q
EN S Y=+B(70) D D^DGPTUTL W ! S Z=5 D Z W $S($P(B(0),U,11)=1:"Date of Disch: ",1:"Census Date : ") S Z=Y,Z1=20 D Z1 W "Disch Specialty: ",$S($D(^DIC(42.4,+$P(B(70),U,2),0)):$E($P(^(0),U,1),1,25),1:"")
W !," Type of Disch: ",$$EXTERNAL^DILFD(45,72,,$P(B(70),U,3))
W ?41,"Disch Status: ",$$EXTERNAL^DILFD(45,72.1,,$P(B(70),U,14))
W !," Place of Disp: ",$S($D(^DIC(45.6,+$P(B(70),U,6),0)):$E($P(^(0),U,1),1,21),1:"")
W ?40 S Z=6 D Z W " Out Treat: ",$P("YES^^NO",U,+$P(B(70),U,4))
W !?6,"Means Test: ",$$EXTERNAL^DILFD(45,10,,$P(B(0),U,10))
W ?42,"VA Auspices: ",$S($P(B(70),U,5)=1:"YES",$P(B(70),U,5)=2:"NO",1:"")
W ! S Z=7 D Z W " Receiv facil: " S Z=$P(B(70),U,12)_$P(B(70),U,13),Z1=18 D Z1 W ?38 S Z="Other Fields" D Z
S DGINC=$P(B(101),U,7)
I DGINC>1000 S DGINC=$E(DGINC,1,$L(DGINC)-3)_","_$E(DGINC,$L(DGINC)-2,$L(DGINC))
W !," C&P Status: ",$$EXTERNAL^DILFD(45,78,,$P(B(70),U,9)),?47,"Income: $",DGINC
K DGINC
AS ;
N DGRSC
S DGRSC=$S($P(A(.3),U)="Y":$$RTEN^DGPTR4($P(A(.3),U,2)),1:"")
W !," ASIH Days: ",$P(B(70),U,8)
W ?40,"SC Percentage: ",$S($P(A(.3),U)="Y":$P(A(.3),U,2)_"%",1:"")
I DGRSC]"",DGRSC'=$P(A(.3),U,2) W ?60,"Transmitted: ["_DGRSC_"%]"
W !,?39,"Period Of Serv: "
W $S($D(^DIC(21,$S('$D(^DGPM(+$O(^DGPM("APTF",PTF,0)),"ODS")):+$$CKPOS^DGPTUTL($P(B(101),U,8),+$P(A(.32),U,3)),+^("ODS"):+$O(^DIC(21,"D",6,0)),1:$$CKPOS^DGPTUTL($P(B(101),U,8),+$P(A(.32),U,3))),0)):$E($P(^(0),U),1,26),1:""),!
Q
;
EN1 ;LOAD AND DISPLAY DIAGNOSES FOR PTF 701 SCREEN
K DRG S B(70)=$S($D(^DGPT(PTF,70)):^(70),1:""),B(71)=$S($D(^DGPT(PTF,71)):^(71),1:"") D WR
N EFFDATE,IMPDATE,J
D EFFDATE^DGPTIC10(PTF)
S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(B(70),U,10),EFFDATE)
S ICDLABEL=$$GETLABEL^DGPTIC10(DGPTDAT,"D")
;
W ! S Z=1 D Z W " Principal Diagnosis: ",ICDLABEL
D WRITECOD^DGPTIC10("DIAG",+$P(B(70),U,10),EFFDATE,2,1,7)
W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"")
; Piece 11 is pre 1986 prin diag
W:$P(B(70),U,11)&('$P(B(70),U,10)) !," Principal Diag: ",ICDLABEL,!?7,$S(DGPTTMP&$P(DGPTTMP,U,10):$P(DGPTTMP,U,4)_" ("_$P(DGPTTMP,U,2)_")",1:"")
N DGPTPOA S DGPTPOA=$G(^DGPT(PTF,82))
;
I $P(DGPTTMP,U,20)=30 W " (POA=",$S($P(DGPTPOA,U)]"":$P(DGPTPOA,U),1:"''"),")"
W !?5,"Secondary Diag: ",ICDLABEL
S K=B(70) F I=16:1:24 S DGPOA=$P(DGPTPOA,"^",(I-14)) D DSP
S K=B(71) F I=1:1:15 S DGPOA=$P(DGPTPOA,"^",(I+10)) D DSP
D:$Y>(IOSL-10) PGBR,WR
S DGPTF=PTF D:'DGST CHK701^DGPTSCAN,UP701^DGPTSPQ
; display contents of 300th node
S DG300=$S($D(^DGPT(PTF,300)):^(300),1:"") D:DG300]"" PRN2^DGPTFM8 K DG300
EN2 K DRG
I $D(^DGPT(PTF,0)),$P(^(0),U,11)=1 D
.S DA=DFN
.D EN1^DGPTFD
.I $D(DRG),$D(^DGP(45.84,PTF,0)),$P(^(0),U,6)'=DRG D
..N DGFDA,DGMSG
..S DGFDA(45.84,PTF_",",6)=DRG
..D FILE^DIE("","DGFDA","DGMSG")
JUMP K AGE,B,CC,DA,DAM,DOB,DXLS,EXP,I,L1,L2,SEX,DRGCAL,S,DIC,DR,DIE
Q:DGPR
K X S $P(X,"-",81)="" W X
;
G O:DGST&(('$D(DRG))!('DGDD)!('$D(^DGP(45.84,PTF))))
X G ACT^DGPTF41
CLS ;
D VERCHK^DGPTRI3(PTF) I $G(DGERR)>0 D HANG^DGPTUTL K DGERR G EN1 ; icd-10 remediation, validate all codes are of correct version
G NOT:('$D(DRG))!('DGDD)!('DGFC)
;change made to allow release of 470, before grouper released to vamc's
; patch 115
;DGDAT = effective date of DRG used in DGPTICD (468=CMS-DRG,998=MS-DRG)
I DRG=469,(+$G(DGDAT)<3071001) W !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7 D HANG^DGPTUTL G EN1
I DRG=998 W !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7 D HANG^DGPTUTL G EN1
I $D(DGCST),'DGCST D CEN G EN1:'DGCST
I '$P(^DGPT(PTF,0),"^",4) W !,"Updating TRANSFER DRGs..." S DGADM=$P(^DGPT(PTF,0),U,2) D SUDO1^DGPTSUDO
I DGDD>(DT+1) W !,"Cannot close with Discharge date in future." D HANG^DGPTUTL G EN1
I $D(^DGM("PT",DFN)) F I=0:0 S I=$O(^DGM("PT",DFN,I)) Q:'I I '$D(^DGM(I,0)) K ^DGM(I),^DGM("PT",DFN,I)
I $D(^DGM("PT",DFN)) W !!,"Not all messages have been cleared up for this patient--cannot close.",*7,*7 S DGPTF=DFN,X="??" K DGALL D HELP^DGPTMSGD K DGPTF G EN1:'$D(DGALL) K DGALL
G CLS^DGPTF2
;
O I '$D(^DGP(45.84,PTF,0)) S DR="6///0",DIE="^DGPT(",DA=PTF,(DGST,DGN)=0 D ^DIE W !," NOT CLOSED " D HANG^DGPTUTL G EN1
S (DGST,DGN)=0
S DGPTIFN=PTF,DGRTY=1 D OPEN^DGPTFDEL S DGST=0
K DGPTIFN,DGRTY G EN1
;
Q G Q^DGPTF
;
NOT I 'DGFC S DR="3//^S X=$P($$SITE^VASITE,U,2);5",DIE="^DGPT(",DA=PTF D ^DIE S DGFC=$P(^DGPT(PTF,0),U,3) I DGFC G EN1
W !!,"Unable to close without a ",$S('$D(DRG):"DRG being calculated.",'DGDD:" discharge date.",1:" facility specified"),!!,*7,*7 H 4 G EN1
Q
;
Z D Z^DGPTF5 Q
Z1 D Z1^DGPTF5 Q
CEN D CEN^DGPTF5 Q
DSP ;
Q:'+$P(K,U,I)
N J2
D WRITECOD^DGPTIC10("DIAG",+$P(K,U,I),EFFDATE,2,1,7)
S J2=$$ICDDATA^ICDXCODE("DIAG",+$P(K,U,I),EFFDATE)
I $P(J2,U,20)=30 W:$X>73 !," " W " (POA=",$S(DGPOA]"":DGPOA,1:"''"),")"
W $S(+J2<1!('$P(J2,U,10)):"*",1:"")
I $Y>(IOSL-3) D PGBR,WR
Q
POA(TEXT) ; -- Returns POA Text
N POA
Q:TEXT="" ""
S POA("Y")="PRESENT ON ADMISSION"
S POA("N")="NOT PRESENT ON ADMISSION"
S POA("U")="INSUFFICIENT DOCUM TO PRESENT ON ADMISSION"
S POA("W")="UNABLE TO DETERM IF PRESENT ON ADMISSION"
Q $G(POA(TEXT))
POA1 ;Y:PRESENT ON ADMISSION;N:NOT PRESENT ON ADMISSION;U:INSUFFICIENT DOCUM TO PRESENT ON ADMISSION;W:UNABLE TO DETERM IF PRESENT ON ADMISSION
;
;
;page break
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[HDGPTF4 5836 printed Sep 23, 2025@20:27:56 Page 2
DGPTF4 ;ALB/JDS/PLT - PTF ENTRY/EDIT-4 ;2/19/04 9:33am
+1 ;;5.3;Registration;**114,115,397,510,517,478,683,775,850,884,1057**;Aug 13, 1993;Build 17
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
WR ;
+1 ; DG*5.3*1057
WRITE @IOF,HEAD,?72
SET Z="<701>"
DO Z^DGPTFM
WRITE !,?30,"Initial Date Of Service: ",$$EXTERNAL^DILFD(45,14,,$GET(DGIDTS))
KILL X
SET $PIECE(X,"-",81)=""
WRITE !,X
+2 QUIT
EN SET Y=+B(70)
DO D^DGPTUTL
WRITE !
SET Z=5
DO Z
WRITE $SELECT($PIECE(B(0),U,11)=1:"Date of Disch: ",1:"Census Date : ")
SET Z=Y
SET Z1=20
DO Z1
WRITE "Disch Specialty: ",$SELECT($DATA(^DIC(42.4,+$PIECE(B(70),U,2),0)):$EXTRACT($PIECE(^(0),U,1),1,25),1:"")
+1 WRITE !," Type of Disch: ",$$EXTERNAL^DILFD(45,72,,$PIECE(B(70),U,3))
+2 WRITE ?41,"Disch Status: ",$$EXTERNAL^DILFD(45,72.1,,$PIECE(B(70),U,14))
+3 WRITE !," Place of Disp: ",$SELECT($DATA(^DIC(45.6,+$PIECE(B(70),U,6),0)):$EXTRACT($PIECE(^(0),U,1),1,21),1:"")
+4 WRITE ?40
SET Z=6
DO Z
WRITE " Out Treat: ",$PIECE("YES^^NO",U,+$PIECE(B(70),U,4))
+5 WRITE !?6,"Means Test: ",$$EXTERNAL^DILFD(45,10,,$PIECE(B(0),U,10))
+6 WRITE ?42,"VA Auspices: ",$SELECT($PIECE(B(70),U,5)=1:"YES",$PIECE(B(70),U,5)=2:"NO",1:"")
+7 WRITE !
SET Z=7
DO Z
WRITE " Receiv facil: "
SET Z=$PIECE(B(70),U,12)_$PIECE(B(70),U,13)
SET Z1=18
DO Z1
WRITE ?38
SET Z="Other Fields"
DO Z
+8 SET DGINC=$PIECE(B(101),U,7)
+9 IF DGINC>1000
SET DGINC=$EXTRACT(DGINC,1,$LENGTH(DGINC)-3)_","_$EXTRACT(DGINC,$LENGTH(DGINC)-2,$LENGTH(DGINC))
+10 WRITE !," C&P Status: ",$$EXTERNAL^DILFD(45,78,,$PIECE(B(70),U,9)),?47,"Income: $",DGINC
+11 KILL DGINC
AS ;
+1 NEW DGRSC
+2 SET DGRSC=$SELECT($PIECE(A(.3),U)="Y":$$RTEN^DGPTR4($PIECE(A(.3),U,2)),1:"")
+3 WRITE !," ASIH Days: ",$PIECE(B(70),U,8)
+4 WRITE ?40,"SC Percentage: ",$SELECT($PIECE(A(.3),U)="Y":$PIECE(A(.3),U,2)_"%",1:"")
+5 IF DGRSC]""
IF DGRSC'=$PIECE(A(.3),U,2)
WRITE ?60,"Transmitted: ["_DGRSC_"%]"
+6 WRITE !,?39,"Period Of Serv: "
+7 WRITE $SELECT($DATA(^DIC(21,$SELECT('$DATA(^DGPM(+$ORDER(^DGPM("APTF",PTF,0)),"ODS")):+$$CKPOS^DGPTUTL($PIECE(B(101),U,8),+...
... $PIECE(A(.32),U,3)),+^("ODS"):+$ORDER(^DIC(21,"D",6,0)),1:$$CKPOS^DGPTUTL($PIECE(B(101),U,8),+$PIECE(A(.32),U,3))),0)):$EXTRACT($PIECE(^(0),U),1,26),1:""),!
+8 QUIT
+9 ;
EN1 ;LOAD AND DISPLAY DIAGNOSES FOR PTF 701 SCREEN
+1 KILL DRG
SET B(70)=$SELECT($DATA(^DGPT(PTF,70)):^(70),1:"")
SET B(71)=$SELECT($DATA(^DGPT(PTF,71)):^(71),1:"")
DO WR
+2 NEW EFFDATE,IMPDATE,J
+3 DO EFFDATE^DGPTIC10(PTF)
+4 SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(B(70),U,10),EFFDATE)
+5 SET ICDLABEL=$$GETLABEL^DGPTIC10(DGPTDAT,"D")
+6 ;
+7 WRITE !
SET Z=1
DO Z
WRITE " Principal Diagnosis: ",ICDLABEL
+8 DO WRITECOD^DGPTIC10("DIAG",+$PIECE(B(70),U,10),EFFDATE,2,1,7)
+9 WRITE $SELECT(+DGPTTMP<1!('$PIECE(DGPTTMP,U,10)):"*",1:"")
+10 ; Piece 11 is pre 1986 prin diag
+11 if $PIECE(B(70),U,11)&('$PIECE(B(70),U,10))
WRITE !," Principal Diag: ",ICDLABEL,!?7,$SELECT(DGPTTMP&$PIECE(DGPTTMP,U,10):$PIECE(DGPTTMP,U,4)_" ("_$PIECE(DGPTTMP,U,2)_")",1:"")
+12 NEW DGPTPOA
SET DGPTPOA=$GET(^DGPT(PTF,82))
+13 ;
+14 IF $PIECE(DGPTTMP,U,20)=30
WRITE " (POA=",$SELECT($PIECE(DGPTPOA,U)]"":$PIECE(DGPTPOA,U),1:"''"),")"
+15 WRITE !?5,"Secondary Diag: ",ICDLABEL
+16 SET K=B(70)
FOR I=16:1:24
SET DGPOA=$PIECE(DGPTPOA,"^",(I-14))
DO DSP
+17 SET K=B(71)
FOR I=1:1:15
SET DGPOA=$PIECE(DGPTPOA,"^",(I+10))
DO DSP
+18 if $Y>(IOSL-10)
DO PGBR
DO WR
+19 SET DGPTF=PTF
if 'DGST
DO CHK701^DGPTSCAN
DO UP701^DGPTSPQ
+20 ; display contents of 300th node
+21 SET DG300=$SELECT($DATA(^DGPT(PTF,300)):^(300),1:"")
if DG300]""
DO PRN2^DGPTFM8
KILL DG300
EN2 KILL DRG
+1 IF $DATA(^DGPT(PTF,0))
IF $PIECE(^(0),U,11)=1
Begin DoDot:1
+2 SET DA=DFN
+3 DO EN1^DGPTFD
+4 IF $DATA(DRG)
IF $DATA(^DGP(45.84,PTF,0))
IF $PIECE(^(0),U,6)'=DRG
Begin DoDot:2
+5 NEW DGFDA,DGMSG
+6 SET DGFDA(45.84,PTF_",",6)=DRG
+7 DO FILE^DIE("","DGFDA","DGMSG")
End DoDot:2
End DoDot:1
JUMP KILL AGE,B,CC,DA,DAM,DOB,DXLS,EXP,I,L1,L2,SEX,DRGCAL,S,DIC,DR,DIE
+1 if DGPR
QUIT
+2 KILL X
SET $PIECE(X,"-",81)=""
WRITE X
+3 ;
+4 if DGST&(('$DATA(DRG))!('DGDD)!('$DATA(^DGP(45.84,PTF))))
GOTO O
X GOTO ACT^DGPTF41
CLS ;
+1 ; icd-10 remediation, validate all codes are of correct version
DO VERCHK^DGPTRI3(PTF)
IF $GET(DGERR)>0
DO HANG^DGPTUTL
KILL DGERR
GOTO EN1
+2 if ('$DATA(DRG))!('DGDD)!('DGFC)
GOTO NOT
+3 ;change made to allow release of 470, before grouper released to vamc's
+4 ; patch 115
+5 ;DGDAT = effective date of DRG used in DGPTICD (468=CMS-DRG,998=MS-DRG)
+6 IF DRG=469
IF (+$GET(DGDAT)<3071001)
WRITE !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7
DO HANG^DGPTUTL
GOTO EN1
+7 IF DRG=998
WRITE !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7
DO HANG^DGPTUTL
GOTO EN1
+8 IF $DATA(DGCST)
IF 'DGCST
DO CEN
if 'DGCST
GOTO EN1
+9 IF '$PIECE(^DGPT(PTF,0),"^",4)
WRITE !,"Updating TRANSFER DRGs..."
SET DGADM=$PIECE(^DGPT(PTF,0),U,2)
DO SUDO1^DGPTSUDO
+10 IF DGDD>(DT+1)
WRITE !,"Cannot close with Discharge date in future."
DO HANG^DGPTUTL
GOTO EN1
+11 IF $DATA(^DGM("PT",DFN))
FOR I=0:0
SET I=$ORDER(^DGM("PT",DFN,I))
if 'I
QUIT
IF '$DATA(^DGM(I,0))
KILL ^DGM(I),^DGM("PT",DFN,I)
+12 IF $DATA(^DGM("PT",DFN))
WRITE !!,"Not all messages have been cleared up for this patient--cannot close.",*7,*7
SET DGPTF=DFN
SET X="??"
KILL DGALL
DO HELP^DGPTMSGD
KILL DGPTF
if '$DATA(DGALL)
GOTO EN1
KILL DGALL
+13 GOTO CLS^DGPTF2
+14 ;
O IF '$DATA(^DGP(45.84,PTF,0))
SET DR="6///0"
SET DIE="^DGPT("
SET DA=PTF
SET (DGST,DGN)=0
DO ^DIE
WRITE !," NOT CLOSED "
DO HANG^DGPTUTL
GOTO EN1
+1 SET (DGST,DGN)=0
+2 SET DGPTIFN=PTF
SET DGRTY=1
DO OPEN^DGPTFDEL
SET DGST=0
+3 KILL DGPTIFN,DGRTY
GOTO EN1
+4 ;
Q GOTO Q^DGPTF
+1 ;
NOT IF 'DGFC
SET DR="3//^S X=$P($$SITE^VASITE,U,2);5"
SET DIE="^DGPT("
SET DA=PTF
DO ^DIE
SET DGFC=$PIECE(^DGPT(PTF,0),U,3)
IF DGFC
GOTO EN1
+1 WRITE !!,"Unable to close without a ",$SELECT('$DATA(DRG):"DRG being calculated.",'DGDD:" discharge date.",1:" facility specified"),!!,*7,*7
HANG 4
GOTO EN1
+2 QUIT
+3 ;
Z DO Z^DGPTF5
QUIT
Z1 DO Z1^DGPTF5
QUIT
CEN DO CEN^DGPTF5
QUIT
DSP ;
+1 if '+$PIECE(K,U,I)
QUIT
+2 NEW J2
+3 DO WRITECOD^DGPTIC10("DIAG",+$PIECE(K,U,I),EFFDATE,2,1,7)
+4 SET J2=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(K,U,I),EFFDATE)
+5 IF $PIECE(J2,U,20)=30
if $X>73
WRITE !," "
WRITE " (POA=",$SELECT(DGPOA]"":DGPOA,1:"''"),")"
+6 WRITE $SELECT(+J2<1!('$PIECE(J2,U,10)):"*",1:"")
+7 IF $Y>(IOSL-3)
DO PGBR
DO WR
+8 QUIT
POA(TEXT) ; -- Returns POA Text
+1 NEW POA
+2 if TEXT=""
QUIT ""
+3 SET POA("Y")="PRESENT ON ADMISSION"
+4 SET POA("N")="NOT PRESENT ON ADMISSION"
+5 SET POA("U")="INSUFFICIENT DOCUM TO PRESENT ON ADMISSION"
+6 SET POA("W")="UNABLE TO DETERM IF PRESENT ON ADMISSION"
+7 QUIT $GET(POA(TEXT))
POA1 ;Y:PRESENT ON ADMISSION;N:NOT PRESENT ON ADMISSION;U:INSUFFICIENT DOCUM TO PRESENT ON ADMISSION;W:UNABLE TO DETERM IF PRESENT ON ADMISSION
+1 ;
+2 ;
+3 ;page break
PGBR NEW DIR,X,Y
SET DIR(0)="E"
SET DIR("A")="Enter RETURN to continue"
DO ^DIR
QUIT
