DGPTF5 ;ALB/MTC/PLT - PTF ENTRY/EDIT-4 ;07 JUN 91
;;5.3;Registration;**669,701,744,868,850,884**;Aug 13, 1993;Build 31
;;Per VA Directive 6402, this routine should not be modified.
;
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
;
CEN ;
W !!,*7,"Record #",PTF," MUST be closed for CENSUS first.",!
ASK W !,"Would you like to close this record for CENSUS" S %=2 D YN^DICN
I '% W !?5,"Answer 'YES' to close record for CENSUS also",!?5," or 'NO' to not close this record at all." G ASK
I %=1 S Y=2 D RTY^DGPTUTL D CLS^DGPTC1
K DGRTY,DGRTY0 Q
ICDEN ;enter icd codes
I $G(X)["?" Q
N DIC,Y I $G(X)="?BAD" S X="" Q
; DG*5.3*701 (movement)
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)
; DG*5.3*744 (801 screen)
E I DA'=$G(PTF),$D(^DGPT(PTF)) D CONFIG^LEXSET("ICD","ICD",$E($$GETDATE^ICDGTDRG($G(PTF)),1,7)) ;868 patch
E D CONFIG^LEXSET("ICD",,$E($$GETDATE^ICDGTDRG(DA)),1,7) ;patch 868
S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"",1:"")_"EQM"
S DIC("A")="Enter ICD: "
D ^DIC
I Y=-1 S X="" Q
S X=$G(Y(1))
Q
ICDEN1 ;enter icd codes for DRG
; called from DGPTFIC and DGPTDRG
; removed kills to X and Y and set for DIC("A")to suppress prompts DG*5.3*850
N DIC,EFFDATE,IMPDATE,TERM,DGTEMP,LEXVDT
I '$G(DGDAT) S DGDAT=DT
S EFFDATE=DGDAT
S DGTEMP=$$IMPDATE^DGPTIC10("10D")
S IMPDATE=$P(DGTEMP,U,1)
;
; What terminology to use, ICD9 or ICD10
I DGDAT<IMPDATE S TERM="ICD"
I DGDAT'<IMPDATE S TERM="10D"
;
; I Testing, set effective date to one stored in file 43
;piece 2 of dgtemp has no 7n value and code below removed
;I EFFDATE'<IMPDATE,+$P(DGTEMP,U,2)?7N S EFFDATE=+$P(DGTEMP,U,2)
;
I $G(PROMPT)'="" S DIC("A")=PROMPT
D CONFIG^LEXSET(TERM,TERM,EFFDATE)
S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"",1:"")_"EQM"
D ^DIC
I Y=-1 S X="" Q
S:TERM="ICD" X=$G(Y(1))
S:TERM="10D" X=$G(Y(30))
S Y=$$ICDDATA^ICDXCODE("DIAG",X,EFFDATE)
K LEXVDT
Q
GETICD9(EFFDATE) ;enter icd codes
N DGXT,DIC,Y,LEXVDT,CUR,ICDV,LEXQ,DO,DISYS,DGY
I $G(X)="?BAD" S X="" G GET9Q
D CONFIG^LEXSET("ICD",EFFDATE)
S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"",1:"")_"EQM"
S DIC("A")="Enter ICD: "
S LEXVDT=EFFDATE
D ^DIC
I Y=-1 S X="" G GET9Q
S DGXT=$G(Y(1))
S X=+$$CODEN^ICDEX(DGXT,80)
GET9Q ; exit point
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTF5 2466 printed Apr 09, 2024@21:59:36 Page 2
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
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
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
+3 ;
Z1 FOR I=1:1:(Z1-$LENGTH(Z))
SET Z=Z_" "
+1 WRITE Z
+2 QUIT
+3 ;
CEN ;
+1 WRITE !!,*7,"Record #",PTF," MUST be closed for CENSUS first.",!
ASK WRITE !,"Would you like to close this record for CENSUS"
SET %=2
DO YN^DICN
+1 IF '%
WRITE !?5,"Answer 'YES' to close record for CENSUS also",!?5," or 'NO' to not close this record at all."
GOTO ASK
+2 IF %=1
SET Y=2
DO RTY^DGPTUTL
DO CLS^DGPTC1
+3 KILL DGRTY,DGRTY0
QUIT
ICDEN ;enter icd codes
+1 IF $GET(X)["?"
QUIT
+2 NEW DIC,Y
IF $GET(X)="?BAD"
SET X=""
QUIT
+3 ; DG*5.3*701 (movement)
+4 ;868 patch,$E($$getdate...),1,7)
IF DA'=$GET(DGPTF)
IF DA<25
IF $GET(DA(1))>0
DO CONFIG^LEXSET("ICD","ICD",$EXTRACT($$GETDATE^ICDGTDRG(DA(1)),1,7))
+5 ; DG*5.3*744 (801 screen)
+6 ;868 patch
IF '$TEST
IF DA'=$GET(PTF)
IF $DATA(^DGPT(PTF))
DO CONFIG^LEXSET("ICD","ICD",$EXTRACT($$GETDATE^ICDGTDRG($GET(PTF)),1,7))
+7 ;patch 868
IF '$TEST
DO CONFIG^LEXSET("ICD",,$EXTRACT($$GETDATE^ICDGTDRG(DA)),1,7)
+8 SET DIC="^LEX(757.01,"
SET DIC(0)=$SELECT('$LENGTH($GET(X)):"",1:"")_"EQM"
+9 SET DIC("A")="Enter ICD: "
+10 DO ^DIC
+11 IF Y=-1
SET X=""
QUIT
+12 SET X=$GET(Y(1))
+13 QUIT
ICDEN1 ;enter icd codes for DRG
+1 ; called from DGPTFIC and DGPTDRG
+2 ; removed kills to X and Y and set for DIC("A")to suppress prompts DG*5.3*850
+3 NEW DIC,EFFDATE,IMPDATE,TERM,DGTEMP,LEXVDT
+4 IF '$GET(DGDAT)
SET DGDAT=DT
+5 SET EFFDATE=DGDAT
+6 SET DGTEMP=$$IMPDATE^DGPTIC10("10D")
+7 SET IMPDATE=$PIECE(DGTEMP,U,1)
+8 ;
+9 ; What terminology to use, ICD9 or ICD10
+10 IF DGDAT<IMPDATE
SET TERM="ICD"
+11 IF DGDAT'<IMPDATE
SET TERM="10D"
+12 ;
+13 ; I Testing, set effective date to one stored in file 43
+14 ;piece 2 of dgtemp has no 7n value and code below removed
+15 ;I EFFDATE'<IMPDATE,+$P(DGTEMP,U,2)?7N S EFFDATE=+$P(DGTEMP,U,2)
+16 ;
+17 IF $GET(PROMPT)'=""
SET DIC("A")=PROMPT
+18 DO CONFIG^LEXSET(TERM,TERM,EFFDATE)
+19 SET DIC="^LEX(757.01,"
SET DIC(0)=$SELECT('$LENGTH($GET(X)):"",1:"")_"EQM"
+20 DO ^DIC
+21 IF Y=-1
SET X=""
QUIT
+22 if TERM="ICD"
SET X=$GET(Y(1))
+23 if TERM="10D"
SET X=$GET(Y(30))
+24 SET Y=$$ICDDATA^ICDXCODE("DIAG",X,EFFDATE)
+25 KILL LEXVDT
+26 QUIT
GETICD9(EFFDATE) ;enter icd codes
+1 NEW DGXT,DIC,Y,LEXVDT,CUR,ICDV,LEXQ,DO,DISYS,DGY
+2 IF $GET(X)="?BAD"
SET X=""
GOTO GET9Q
+3 DO CONFIG^LEXSET("ICD",EFFDATE)
+4 SET DIC="^LEX(757.01,"
SET DIC(0)=$SELECT('$LENGTH($GET(X)):"",1:"")_"EQM"
+5 SET DIC("A")="Enter ICD: "
+6 SET LEXVDT=EFFDATE
+7 DO ^DIC
+8 IF Y=-1
SET X=""
GOTO GET9Q
+9 SET DGXT=$GET(Y(1))
+10 SET X=+$$CODEN^ICDEX(DGXT,80)
GET9Q ; exit point
+1 QUIT X
