DGPTODR ;ALB/ABS/ADL - DRG Information Report ;11/15/06 2:57pm
;;5.3;Registration;**510,729,850**;Aug 13, 1993;Build 171
;;ADL;Update for CSV Project;;Mar 28, 2003
S DGTMP=DGDX,DGDRGPRT=1,(DGPG,DGQ)=0,$P(DGLN,"=",81)="" D HDR
F DGX=1:1 Q:$P(DGTMP,"^",DGX)']"" D CONT:$E(IOST,1,2)="C-" Q:DGQ["^" D
. W !,DGLN,!?10,"PRINCIPAL DIAGNOSIS:",$J($P(DGDX(DGX),"^"),8)," ",$P(DGDX(DGX),"^",2) D ^DGPTICD S DGDX=$P(DGDX,"^",2,99)_"^"_$P(DGDX,"^")
Q K AGE,NAME,SEX,DGDMS,DGDRGPRT,DGDX,DGEXP,DGSURG,DGTRS,DGLN,DGPG,DGQ,DGTMP,DGX,DGPTODR,I,Y Q
HDR ;print heading
S DGPG=DGPG+1 W @IOF,"DRG INFORMATION REPORT",?45,"Date: " S Y=DT X ^DD("DD") W Y," Page: ",DGPG,!!
S Y=DGDAT D DD^%DT ; Y = external format of effective date
W "Effective Date: ",Y,! I NAME]"" W "Patient: ",NAME,?40
W "Sex: ",$S(SEX="M":"Male",1:"Female"),?61,"Age: ",AGE,!,"Expired: ",$S(DGEXP:"Yes",1:"No"),?18,"Transferred to Acute Care: ",$S(DGTRS:"Yes",1:"No"),?55,"Irreg D/C: ",$S(DGDMS:"Yes",1:"No")
Q:DGPG'=1 W !!,"Diagnosis Codes:" F I=0:0 S I=$O(DGDX(I)) Q:I'>0 W !,$J($P(DGDX(I),"^"),8)," ",$P(DGDX(I),"^",2) I $G(DGDXPOA)'="" D
. W:DGTERMIN="10D" " (POA="_$P(DGDXPOA,"^",I)_")"
I $D(DGSURG) W !!,"Operation/Procedure Codes:" F I=0:0 S I=$O(DGSURG(I)) Q:I'>0 W !,$J($P(DGSURG(I),"^"),8)," ",$P(DGSURG(I),"^",2)
Q
CONT I $Y+8>IOSL R !!?20,"Press <RET> to continue or ""^"" to abort ",DGQ:DTIME S:'$T DGQ="^" Q:DGQ["^" D HDR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTODR 1430 printed Dec 13, 2024@02:53:11 Page 2
DGPTODR ;ALB/ABS/ADL - DRG Information Report ;11/15/06 2:57pm
+1 ;;5.3;Registration;**510,729,850**;Aug 13, 1993;Build 171
+2 ;;ADL;Update for CSV Project;;Mar 28, 2003
+3 SET DGTMP=DGDX
SET DGDRGPRT=1
SET (DGPG,DGQ)=0
SET $PIECE(DGLN,"=",81)=""
DO HDR
+4 FOR DGX=1:1
if $PIECE(DGTMP,"^",DGX)']""
QUIT
if $EXTRACT(IOST,1,2)="C-"
DO CONT
if DGQ["^"
QUIT
Begin DoDot:1
+5 WRITE !,DGLN,!?10,"PRINCIPAL DIAGNOSIS:",$JUSTIFY($PIECE(DGDX(DGX),"^"),8)," ",$PIECE(DGDX(DGX),"^",2)
DO ^DGPTICD
SET DGDX=$PIECE(DGDX,"^",2,99)_"^"_$PIECE(DGDX,"^")
End DoDot:1
Q KILL AGE,NAME,SEX,DGDMS,DGDRGPRT,DGDX,DGEXP,DGSURG,DGTRS,DGLN,DGPG,DGQ,DGTMP,DGX,DGPTODR,I,Y
QUIT
HDR ;print heading
+1 SET DGPG=DGPG+1
WRITE @IOF,"DRG INFORMATION REPORT",?45,"Date: "
SET Y=DT
XECUTE ^DD("DD")
WRITE Y," Page: ",DGPG,!!
+2 ; Y = external format of effective date
SET Y=DGDAT
DO DD^%DT
+3 WRITE "Effective Date: ",Y,!
IF NAME]""
WRITE "Patient: ",NAME,?40
+4 WRITE "Sex: ",$SELECT(SEX="M":"Male",1:"Female"),?61,"Age: ",AGE,!,"Expired: ",$SELECT(DGEXP:"Yes",1:"No"),?18,"Transferred to Acute Care: ",$SELECT(DGTRS:"Yes",1:"No"),?55,"Irreg D/C: ",$SELECT(DGDMS:"Yes",1:"No")
+5 if DGPG'=1
QUIT
WRITE !!,"Diagnosis Codes:"
FOR I=0:0
SET I=$ORDER(DGDX(I))
if I'>0
QUIT
WRITE !,$JUSTIFY($PIECE(DGDX(I),"^"),8)," ",$PIECE(DGDX(I),"^",2)
IF $GET(DGDXPOA)'=""
Begin DoDot:1
+6 if DGTERMIN="10D"
WRITE " (POA="_$PIECE(DGDXPOA,"^",I)_")"
End DoDot:1
+7 IF $DATA(DGSURG)
WRITE !!,"Operation/Procedure Codes:"
FOR I=0:0
SET I=$ORDER(DGSURG(I))
if I'>0
QUIT
WRITE !,$JUSTIFY($PIECE(DGSURG(I),"^"),8)," ",$PIECE(DGSURG(I),"^",2)
+8 QUIT
CONT IF $Y+8>IOSL
READ !!?20,"Press <RET> to continue or ""^"" to abort ",DGQ:DTIME
if '$TEST
SET DGQ="^"
if DGQ["^"
QUIT
DO HDR
+1 QUIT
