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