DGPTODI2 ;ALB/AS - DRG INDEX (CONT), SETS ^UTILITY GLOBAL ; 22 MAY 87 09:00
;;5.3;Registration;**158**;Aug 13, 1993
D DT^DICRW,Q,SET^DGPTODI4,ADM:DGD=0,DC:DGD,C^DGUTL,^DGPTODI3,TP^DGUTL,CLOSE^DGUTQ
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
Q K ^UTILITY($J,"DGDRGI"),^UTILITY($J,"DGTC") Q
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)
Q
ADM S DGDCDT="",DGSTAT=0
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
Q
PT S DFN=+X I DGS'="A" Q:DGS'=DGSTAT
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
S (DGTRDT,DRG)=""
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
I DRG']"" D NC Q
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
R S DGQ="" I DGR=1 S:(DRG<DGC1!(DRG>DGC2)) DGQ=1 Q
S:DRG'=DGC1 DGQ=1 Q
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
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)
S Y=$S(DGTRDT>0:DGTRDT,DGDCDT]"":DGDCDT,1:1)
S ^UTILITY($J,"DGDRGI",DRG,X,DGPTF,Y)=SSN_"^"_DFN_"^"_DGLOS_"^"_DGPRO_"^"_DGBS_"^"_DGADMDT_"^"_DGDCDT_"^"_DGSTAT_"^"_DGBE Q
NC S:DGC ^UTILITY($J,"DGDRGI","DGNOCODE",DGPTF)=DFN_"^"_DGADMDT Q
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+%)
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
S DGBS=$P(^DGPT(DGPTF,"M",1,0),"^",2),DGPRO=$S($D(^DPT(DFN,.104)):+^(.104),1:"")
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:"")
Q
DGPRO S DGPRO=$S('$D(^DGPT(DGPTF,"M",1,"P")):"Unknown",$D(^VA(200,+$P(^("P"),"^",5),0)):$P(^(0),"^"),1:"Unknown")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTODI2 2862 printed Jan 18, 2025@03:53:49 Page 2
DGPTODI2 ;ALB/AS - DRG INDEX (CONT), SETS ^UTILITY GLOBAL ; 22 MAY 87 09:00
+1 ;;5.3;Registration;**158**;Aug 13, 1993
+2 DO DT^DICRW
DO Q
DO SET^DGPTODI4
if DGD=0
DO ADM
if DGD
DO DC
DO C^DGUTL
DO ^DGPTODI3
DO TP^DGUTL
DO CLOSE^DGUTQ
+3 KILL %,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
Q KILL ^UTILITY($JOB,"DGDRGI"),^UTILITY($JOB,"DGTC")
QUIT
DC FOR DGDCDT=DGSD:0
SET DGDCDT=$ORDER(^DGPT("ADS",DGDCDT))
if DGDCDT>DGED!('DGDCDT)
QUIT
FOR DGPTF=0:0
SET DGPTF=$ORDER(^DGPT("ADS",DGDCDT,DGPTF))
if 'DGPTF
QUIT
SET X=$SELECT($DATA(^DGPT(DGPTF,0)):^(0),1:0)
IF X
SET DGADMDT=$PIECE(X,U,2)
SET DGSTAT=$PIECE(X,U,6)
IF DGSTAT]""
if '$PIECE(X,U,4)
DO PT
+1 QUIT
ADM SET DGDCDT=""
SET DGSTAT=0
+1 FOR DGADMDT=DGSD:0
SET DGADMDT=$ORDER(^DGPT("AADA",DGADMDT))
if DGADMDT'>0
QUIT
FOR DGPTF=0:0
SET DGPTF=$ORDER(^DGPT("AADA",DGADMDT,DGPTF))
if DGPTF'>0
QUIT
IF $DATA(^DGPT(DGPTF,0))
SET %=^DGPT(DGPTF,0)
SET DFN=+%
if $PIECE(%,"^",4)=1
QUIT
DO B
+2 QUIT
PT SET DFN=+X
IF DGS'="A"
if DGS'=DGSTAT
QUIT
B IF DGB
FOR DGPTD1=1:0
SET DGPTD1=$ORDER(^DGPT(DGPTF,"M",DGPTD1))
if DGPTD1'>0
QUIT
IF $DATA(^(DGPTD1,"P"))
SET Z=^("P")
SET DRG=+Z
if DRG'>0
DO NC
IF DRG>0
if DGR'=2
DO R
IF 'DGQ
DO TRF
+1 SET (DGTRDT,DRG)=""
+2 IF $DATA(^DGPT(DGPTF,"M",1,"P"))
SET %=^("P")
SET DGLOS=$SELECT(DGB:$PIECE(%,"^",4),1:$PIECE(%,"^",6))
if DGB
SET DRG=$PIECE(%,"^")
IF 'DGB
if DGSTAT'=0
SET DRG=$SELECT($DATA(^DGP(45.84,DGPTF,0)):$PIECE(^(0),"^",6),1:"")
IF DGSTAT=0
SET PTF=DGPTF
DO EN1^DGPTFD
IF '$DATA(DRG)
DO NC
QUIT
+3 IF DRG']""
DO NC
QUIT
+4 if DGR'=2
DO R
if DGQ
QUIT
if DGD
SET %=$SELECT($DATA(^DGPT(DGPTF,70)):^(70),1:"")
SET DGBS=$PIECE(%,"^",2)
if DGD
DO DGPRO
if DGD
DO BE
if 'DGD
DO CUR
DO SET
QUIT
R SET DGQ=""
IF DGR=1
if (DRG<DGC1!(DRG>DGC2))
SET DGQ=1
QUIT
+1 if DRG'=DGC1
SET DGQ=1
QUIT
TRF SET DGLOS=$PIECE(Z,"^",4)
SET DGPRO=$PIECE(Z,"^",5)
SET DGBS=$PIECE(^DGPT(DGPTF,"M",DGPTD1,0),"^",2)
SET DGTRDT=$PIECE(Z,"^",3)
SET DGSV=""
DO BE
SET SET X=$SELECT(DGP:$PIECE(^DPT(DFN,0),"^",1),1:0)
SET SSN=$PIECE(^DPT(DFN,0),"^",9)
IF X=0
SET X=" "_$EXTRACT(SSN,8,9)_$EXTRACT(SSN,6,7)_$EXTRACT(SSN,4,5)_$EXTRACT(SSN,1,3)
+1 SET Y=$SELECT(DGTRDT>0:DGTRDT,DGDCDT]"":DGDCDT,1:1)
+2 SET ^UTILITY($JOB,"DGDRGI",DRG,X,DGPTF,Y)=SSN_"^"_DFN_"^"_DGLOS_"^"_DGPRO_"^"_DGBS_"^"_DGADMDT_"^"_DGDCDT_"^"_DGSTAT_"^"_DGBE
QUIT
NC if DGC
SET ^UTILITY($JOB,"DGDRGI","DGNOCODE",DGPTF)=DFN_"^"_DGADMDT
QUIT
CUR SET DGPN=""
SET DGLEV=0
FOR I=0:0
SET I=$ORDER(^DGPT(DGPTF,"M","AM",I))
if I'>""
QUIT
FOR J=0:0
SET J=$ORDER(^DGPT(DGPTF,"M","AM",I,J))
if J'>""
QUIT
if $DATA(^DGPT(DGPTF,"M",J,"P"))
SET DGPN=J
SET %=^DGPT(DGPTF,"M",J,0)
SET %=$PIECE(%,"^",3)+$PIECE(%,"^",4)
SET DGLEV=$SELECT(J=DGPN:%,1:DGLEV+%)
+1 SET X1=DT
SET X2=$SELECT(DGPN:$PIECE(^DGPT(DGPTF,"M",DGPN,"P"),"^",3),1:$PIECE(^DGPT(DGPTF,0),"^",2))
DO ^%DTC
SET DGLOS=X-DGLEV
if DGLOS<1
SET DGLOS=1
KILL DGPN,DGLEV,J,X1,X2
+2 SET DGBS=$PIECE(^DGPT(DGPTF,"M",1,0),"^",2)
SET DGPRO=$SELECT($DATA(^DPT(DFN,.104)):+^(.104),1:"")
BE IF DGBS]""
SET DGSV=$SELECT($DATA(^DIC(42.4,DGBS,0)):$PIECE(^(0),"^",3),1:"")
IF DGSV]""
SET DGSV=$SELECT(DGSV="M":1,DGSV="NE":2,DGSV="P":3,DGSV="R":4,1:5)
SET DGBE=$SELECT($DATA(^ICD(DRG,"BE",DGFYQ,"S",+DGSV,0)):$PIECE(^(0),"^",2),1:"")
+1 QUIT
DGPRO SET DGPRO=$SELECT('$DATA(^DGPT(DGPTF,"M",1,"P")):"Unknown",$DATA(^VA(200,+$PIECE(^("P"),"^",5),0)):$PIECE(^(0),"^"),1:"Unknown")
+1 QUIT
