- 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 Feb 19, 2025@00:18:06 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