| 1 | DGPTF5 ;ALB/MTC - PTF ENTRY/EDIT-4 ; 07 JUN 91
|
|---|
| 2 | ;;5.3;Registration;**669,701,744**;Aug 13, 1993;Build 5
|
|---|
| 3 | ;
|
|---|
| 4 | Z I 'DGN S Z=$S(IOST="C-QUME"&($L(DGVI)'=2):Z,1:"["_Z_"]") W @DGVI,Z,@DGVO
|
|---|
| 5 | E W " "
|
|---|
| 6 | Q
|
|---|
| 7 | ;
|
|---|
| 8 | Z1 F I=1:1:(Z1-$L(Z)) S Z=Z_" "
|
|---|
| 9 | W Z
|
|---|
| 10 | Q
|
|---|
| 11 | ;
|
|---|
| 12 | CEN ;
|
|---|
| 13 | W !!,*7,"Record #",PTF," MUST be closed for CENSUS first.",!
|
|---|
| 14 | ASK W !,"Would you like to close this record for CENSUS" S %=2 D YN^DICN
|
|---|
| 15 | I '% W !?5,"Answer 'YES' to close record for CENSUS also",!?5," or 'NO' to not close this record at all." G ASK
|
|---|
| 16 | I %=1 S Y=2 D RTY^DGPTUTL D CLS^DGPTC1
|
|---|
| 17 | K DGRTY,DGRTY0 Q
|
|---|
| 18 | ICDEN ;enter icd codes
|
|---|
| 19 | I $G(X)["?" Q
|
|---|
| 20 | N DIC,Y I $G(X)="?BAD" S X="" Q
|
|---|
| 21 | ; DG*5.3*701 (movement)
|
|---|
| 22 | I DA'=$G(DGPTF),DA<25,$G(DA(1))>0 D CONFIG^LEXSET("ICD",,$$GETDATE^ICDGTDRG(DA(1)))
|
|---|
| 23 | ; DG*5.3*744 (801 screen)
|
|---|
| 24 | E I DA'=$G(PTF),$D(^DGPT(PTF)) D CONFIG^LEXSET("ICD",,$$GETDATE^ICDGTDRG($G(PTF)))
|
|---|
| 25 | E D CONFIG^LEXSET("ICD",,$$GETDATE^ICDGTDRG(DA))
|
|---|
| 26 | S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"",1:"")_"EQM"
|
|---|
| 27 | S DIC("A")="Enter ICD: "
|
|---|
| 28 | D ^DIC
|
|---|
| 29 | I Y=-1 S X="" Q
|
|---|
| 30 | S X=$G(Y(1))
|
|---|
| 31 | Q
|
|---|
| 32 | ICDEN1 ;enter icd codes for DRG
|
|---|
| 33 | N DIC K X,Y
|
|---|
| 34 | D CONFIG^LEXSET("ICD",,$G(DGDAT))
|
|---|
| 35 | S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"",1:"")_"EQM"
|
|---|
| 36 | S DIC("A")=PROMPT
|
|---|
| 37 | D ^DIC
|
|---|
| 38 | I Y=-1 S X="" Q
|
|---|
| 39 | S X=$G(Y(1))
|
|---|
| 40 | S Y=$$ICDDX^ICDCODE(X,$G(DGDAT))
|
|---|
| 41 | Q
|
|---|
