Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPTF5

DGPTF5.m

Go to the documentation of this file.
  1. DGPTF5 ;ALB/MTC/PLT - PTF ENTRY/EDIT-4 ;07 JUN 91
  1. ;;5.3;Registration;**669,701,744,868,850,884**;Aug 13, 1993;Build 31
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. Z I 'DGN S Z=$S(IOST="C-QUME"&($L(DGVI)'=2):Z,1:"["_Z_"]") W @DGVI,Z,@DGVO
  1. E W " "
  1. Q
  1. ;
  1. Z1 F I=1:1:(Z1-$L(Z)) S Z=Z_" "
  1. W Z
  1. Q
  1. ;
  1. CEN ;
  1. W !!,*7,"Record #",PTF," MUST be closed for CENSUS first.",!
  1. ASK W !,"Would you like to close this record for CENSUS" S %=2 D YN^DICN
  1. I '% W !?5,"Answer 'YES' to close record for CENSUS also",!?5," or 'NO' to not close this record at all." G ASK
  1. I %=1 S Y=2 D RTY^DGPTUTL D CLS^DGPTC1
  1. K DGRTY,DGRTY0 Q
  1. ICDEN ;enter icd codes
  1. I $G(X)["?" Q
  1. N DIC,Y I $G(X)="?BAD" S X="" Q
  1. ; DG*5.3*701 (movement)
  1. I DA'=$G(DGPTF),DA<25,$G(DA(1))>0 D CONFIG^LEXSET("ICD","ICD",$E($$GETDATE^ICDGTDRG(DA(1)),1,7)) ;868 patch,$E($$getdate...),1,7)
  1. ; DG*5.3*744 (801 screen)
  1. E I DA'=$G(PTF),$D(^DGPT(PTF)) D CONFIG^LEXSET("ICD","ICD",$E($$GETDATE^ICDGTDRG($G(PTF)),1,7)) ;868 patch
  1. E D CONFIG^LEXSET("ICD",,$E($$GETDATE^ICDGTDRG(DA)),1,7) ;patch 868
  1. S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"",1:"")_"EQM"
  1. S DIC("A")="Enter ICD: "
  1. D ^DIC
  1. I Y=-1 S X="" Q
  1. S X=$G(Y(1))
  1. Q
  1. ICDEN1 ;enter icd codes for DRG
  1. ; called from DGPTFIC and DGPTDRG
  1. ; removed kills to X and Y and set for DIC("A")to suppress prompts DG*5.3*850
  1. N DIC,EFFDATE,IMPDATE,TERM,DGTEMP,LEXVDT
  1. I '$G(DGDAT) S DGDAT=DT
  1. S EFFDATE=DGDAT
  1. S DGTEMP=$$IMPDATE^DGPTIC10("10D")
  1. S IMPDATE=$P(DGTEMP,U,1)
  1. ;
  1. ; What terminology to use, ICD9 or ICD10
  1. I DGDAT<IMPDATE S TERM="ICD"
  1. I DGDAT'<IMPDATE S TERM="10D"
  1. ;
  1. ; I Testing, set effective date to one stored in file 43
  1. ;piece 2 of dgtemp has no 7n value and code below removed
  1. ;I EFFDATE'<IMPDATE,+$P(DGTEMP,U,2)?7N S EFFDATE=+$P(DGTEMP,U,2)
  1. ;
  1. I $G(PROMPT)'="" S DIC("A")=PROMPT
  1. D CONFIG^LEXSET(TERM,TERM,EFFDATE)
  1. S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"",1:"")_"EQM"
  1. D ^DIC
  1. I Y=-1 S X="" Q
  1. S:TERM="ICD" X=$G(Y(1))
  1. S:TERM="10D" X=$G(Y(30))
  1. S Y=$$ICDDATA^ICDXCODE("DIAG",X,EFFDATE)
  1. K LEXVDT
  1. Q
  1. GETICD9(EFFDATE) ;enter icd codes
  1. N DGXT,DIC,Y,LEXVDT,CUR,ICDV,LEXQ,DO,DISYS,DGY
  1. I $G(X)="?BAD" S X="" G GET9Q
  1. D CONFIG^LEXSET("ICD",EFFDATE)
  1. S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"",1:"")_"EQM"
  1. S DIC("A")="Enter ICD: "
  1. S LEXVDT=EFFDATE
  1. D ^DIC
  1. I Y=-1 S X="" G GET9Q
  1. S DGXT=$G(Y(1))
  1. S X=+$$CODEN^ICDEX(DGXT,80)
  1. GET9Q ; exit point
  1. Q X