| 1 | DGPTODI2 ;ALB/AS - DRG INDEX (CONT), SETS ^UTILITY GLOBAL ; 22 MAY 87 09:00
|
|---|
| 2 | ;;5.3;Registration;**158**;Aug 13, 1993
|
|---|
| 3 | D DT^DICRW,Q,SET^DGPTODI4,ADM:DGD=0,DC:DGD,C^DGUTL,^DGPTODI3,TP^DGUTL,CLOSE^DGUTQ
|
|---|
| 4 | K %,D0,D1,I,DFN,DGADMDT,DGB,DGBS,DGC1,DGC2,DGCPG,DGD,DGD1,DGDCDT,DGED,DGLOS,DGNCCT,DGP,DGPRO,DGPTD1,DGPTF,DGQ,DGR,DGS,DGSD,DGSTAT,DGTCH,DGTRDT,DRG,PTF,SSN,X,Y,Z,DGDT,DGFY,DGFYQ,DGSV,DGBE,DGCPT,DGFY2K
|
|---|
| 5 | Q K ^UTILITY($J,"DGDRGI"),^UTILITY($J,"DGTC") Q
|
|---|
| 6 | DC F DGDCDT=DGSD:0 S DGDCDT=$O(^DGPT("ADS",DGDCDT)) Q:DGDCDT>DGED!('DGDCDT) F DGPTF=0:0 S DGPTF=$O(^DGPT("ADS",DGDCDT,DGPTF)) Q:'DGPTF S X=$S($D(^DGPT(DGPTF,0)):^(0),1:0) I X S DGADMDT=$P(X,U,2),DGSTAT=$P(X,U,6) I DGSTAT]"" D PT:'$P(X,U,4)
|
|---|
| 7 | Q
|
|---|
| 8 | ADM S DGDCDT="",DGSTAT=0
|
|---|
| 9 | F DGADMDT=DGSD:0 S DGADMDT=$O(^DGPT("AADA",DGADMDT)) Q:DGADMDT'>0 F DGPTF=0:0 S DGPTF=$O(^DGPT("AADA",DGADMDT,DGPTF)) Q:DGPTF'>0 I $D(^DGPT(DGPTF,0)) S %=^DGPT(DGPTF,0),DFN=+% Q:$P(%,"^",4)=1 D B
|
|---|
| 10 | Q
|
|---|
| 11 | PT S DFN=+X I DGS'="A" Q:DGS'=DGSTAT
|
|---|
| 12 | B I DGB F DGPTD1=1:0 S DGPTD1=$O(^DGPT(DGPTF,"M",DGPTD1)) Q:DGPTD1'>0 I $D(^(DGPTD1,"P")) S Z=^("P"),DRG=+Z D:DRG'>0 NC I DRG>0 D R:DGR'=2 I 'DGQ D TRF
|
|---|
| 13 | S (DGTRDT,DRG)=""
|
|---|
| 14 | I $D(^DGPT(DGPTF,"M",1,"P")) S %=^("P"),DGLOS=$S(DGB:$P(%,"^",4),1:$P(%,"^",6)) S:DGB DRG=$P(%,"^") I 'DGB S:DGSTAT'=0 DRG=$S($D(^DGP(45.84,DGPTF,0)):$P(^(0),"^",6),1:"") I DGSTAT=0 S PTF=DGPTF D EN1^DGPTFD I '$D(DRG) D NC Q
|
|---|
| 15 | I DRG']"" D NC Q
|
|---|
| 16 | D R:DGR'=2 Q:DGQ S:DGD %=$S($D(^DGPT(DGPTF,70)):^(70),1:""),DGBS=$P(%,"^",2) D DGPRO:DGD,BE:DGD,CUR:'DGD D SET Q
|
|---|
| 17 | R S DGQ="" I DGR=1 S:(DRG<DGC1!(DRG>DGC2)) DGQ=1 Q
|
|---|
| 18 | S:DRG'=DGC1 DGQ=1 Q
|
|---|
| 19 | TRF S DGLOS=$P(Z,"^",4),DGPRO=$P(Z,"^",5),DGBS=$P(^DGPT(DGPTF,"M",DGPTD1,0),"^",2),DGTRDT=$P(Z,"^",3),DGSV="" D BE
|
|---|
| 20 | SET S X=$S(DGP:$P(^DPT(DFN,0),"^",1),1:0),SSN=$P(^DPT(DFN,0),"^",9) I X=0 S X=" "_$E(SSN,8,9)_$E(SSN,6,7)_$E(SSN,4,5)_$E(SSN,1,3)
|
|---|
| 21 | S Y=$S(DGTRDT>0:DGTRDT,DGDCDT]"":DGDCDT,1:1)
|
|---|
| 22 | S ^UTILITY($J,"DGDRGI",DRG,X,DGPTF,Y)=SSN_"^"_DFN_"^"_DGLOS_"^"_DGPRO_"^"_DGBS_"^"_DGADMDT_"^"_DGDCDT_"^"_DGSTAT_"^"_DGBE Q
|
|---|
| 23 | NC S:DGC ^UTILITY($J,"DGDRGI","DGNOCODE",DGPTF)=DFN_"^"_DGADMDT Q
|
|---|
| 24 | CUR S DGPN="",DGLEV=0 F I=0:0 S I=$O(^DGPT(DGPTF,"M","AM",I)) Q:I'>"" F J=0:0 S J=$O(^DGPT(DGPTF,"M","AM",I,J)) Q:J'>"" S:$D(^DGPT(DGPTF,"M",J,"P")) DGPN=J,%=^DGPT(DGPTF,"M",J,0),%=$P(%,"^",3)+$P(%,"^",4),DGLEV=$S(J=DGPN:%,1:DGLEV+%)
|
|---|
| 25 | S X1=DT,X2=$S(DGPN:$P(^DGPT(DGPTF,"M",DGPN,"P"),"^",3),1:$P(^DGPT(DGPTF,0),"^",2)) D ^%DTC S DGLOS=X-DGLEV S:DGLOS<1 DGLOS=1 K DGPN,DGLEV,J,X1,X2
|
|---|
| 26 | S DGBS=$P(^DGPT(DGPTF,"M",1,0),"^",2),DGPRO=$S($D(^DPT(DFN,.104)):+^(.104),1:"")
|
|---|
| 27 | BE I DGBS]"" S DGSV=$S($D(^DIC(42.4,DGBS,0)):$P(^(0),"^",3),1:"") I DGSV]"" S DGSV=$S(DGSV="M":1,DGSV="NE":2,DGSV="P":3,DGSV="R":4,1:5),DGBE=$S($D(^ICD(DRG,"BE",DGFYQ,"S",+DGSV,0)):$P(^(0),"^",2),1:"")
|
|---|
| 28 | Q
|
|---|
| 29 | DGPRO S DGPRO=$S('$D(^DGPT(DGPTF,"M",1,"P")):"Unknown",$D(^VA(200,+$P(^("P"),"^",5),0)):$P(^(0),"^"),1:"Unknown")
|
|---|
| 30 | Q
|
|---|
