DGPMV33 ;ALB/MIR - DISCHARGE A PATIENT, CONTINUED ; 8/4/03 1:13pm
;;5.3;Registration;**204,544**;Aug 13, 1993
;
I '$P(DGPMA,"^",4)!$S($P(DGPMA,"^",18)'=10:0,'$P(DGPMA,"^",5):1,1:0) W !,"Incomplete Discharge" S DIK="^DGPM(",DA=DGPMDA D ^DIK W " deleted" S DGPMA="" D G Q
.S ^UTILITY("DGPM",$J,3,DA,"A")=$G(^("P"))
.I $G(DGPMVI(13)) I $D(^UTILITY("DGPM",$J,1,+DGPMVI(13),"A")) S $P(^("A"),U,17)=$P($G(^("P")),U,17)
S DGPMPTF=$P(DGPMAN,"^",16) G DQ:'DGPMPTF
S X=$S($D(^DG(405.2,+$P(DGPMA,"^",18),0)):$P(^(0),"^",8),1:""),DR=$S(+DGPMA:"70////"_+DGPMA_";",1:"")_$S(X:"72////"_X,1:""),DIE="^DGPT(",DA=DGPMPTF K DQ,DG D ^DIE
I +DGPMP=+DGPMA G Q
DQ S DGPMER=0 I $P(DGPMAN,"^",18)=40 D SET^DGPMV32 I DGPMAB S X1=+DGPMAB,X2=30 D C^%DTC I X'<+DGPMA D ASIH^DGPMV331
;I 'DGPMER,$D(^DGPM(+DGPMDA,0)) D ADM
I DGPMN D DIS^DGPMVODS
W !,"Patient Discharge",$S('$D(^DGPM(+DGPMDA,0)):" Deleted",DGPMA=DGPMP:"",'DGPMP:"d",1:" Updated")
Q Q
DICS ;input transform on discharge type
S DGX1=$P(^DG(405.1,+Y,0),"^",3),DGSV=$S($D(^DIC(42,+$P(DGPM0,"^",6),0)):$P(^(0),"^",3),1:"")
I DGX1=33,$S(DGSV="":1,DGSV'="D":1,1:0) S DGER=1 Q
I DGX1=35,$S(DGSV="":1,DGSV'="NH":1,1:0) S DGER=1 Q
I $S(DGX1=31:1,DGX1=32:1,1:0),$S(DGSV="":0,"NHD"[DGSV:1,1:0) S DGER=1 Q
I DGX1=34,$S(DGSV="":1,DGSV="NH":1,1:0) S DGER=1 Q
;I "^21^47^48^49^"[("^"_DGX1_"^") S DGER=1 Q
I DGX1=42,'$O(^DGPM("ATID2",+$P(^DGPM(DA,0),"^",3),9999999.9999999-^(0))) S DGER=1 Q
S DGX=+$P(DGPMP,"^",18) I DGX,"^41^46^"[("^"_DGX_"^"),(DGX1'=DGX) S DGER=1 Q
I "^42^47^"[("^"_DGX1_"^"),(DGX1'=$P(^DGPM(DA,0),"^",18)) S DGER=1 Q
I "^42^47^"[("^"_DGX_"^"),(DGX1'=$P(^DGPM(DA,0),"^",18)) S DGER=1 Q
I DGX,"^41^42^46^47^"'[("^"_DGX_"^"),("^41^42^46^47^"[("^"_DGX1_"^")) S DGER=1 Q
I $P(DGPMAN,"^",18)=40,("^42^47^"[("^"_DGX1_"^")) S DGER=1 Q ;if admission type is TO ASIH and d/c type is WHILE ASIH
I $P(DGPMAN,"^",18)'=40,("^41^46^"[("^"_DGX1_"^")) S DGER=1 Q ;if adm type not TO ASIH and d/c type FROM ASIH or CONTINUED ASIH (O.F.)
I $P(DGPMAN,"^",18)'=40 S DGER=0 Q
I "^41^46^"'[("^"_DGX1_"^") S DGER=0 Q
D SET^DGPMV32 S X1=+DGPMAB,X2=30,DGHX=X D C^%DTC I ^DGPM(DA,0)>X S DGER=1,X=DGHX K DGHX Q
S X=DGHX,DGER=0 K DGHX
I $D(^DGPM(+$P(DGPMAN,"^",21),0)),$D(^DGPM(+$P(^(0),"^",14),0)),$D(^DGPM(+$P(^(0),"^",17),0)),($P(^(0),"^",18)=47) S DGER=1 Q ;if discharge from NHCU/DOM is type 47
S DGER=0 Q
SI Q:"^25^26^"[("^"_$P(DGPMA,"^",18)_"^")
I $S('$D(^DPT(DFN,.1)):1,^(.1)="":1,1:0)&($D(^("DAC"))) S DR="401.3///@",DIE="^DPT(",DA=DFN K DQ,DG D ^DIE:$P(^("DAC"),"^",1)="S" K DR,DIC Q
Q:'$D(^DPT(DFN,.1)) S W=^(.1) Q:W']"" S W=$O(^DIC(42,"B",W,0)),W=$S($D(^DIC(42,+W,0)):^(0),1:""),T="SERIOUSLY ILL" Q:W=""
I $P(W,"^",14),($P(DGPMA,"^",18)>3) D Q
.S DR="401.3//"_$S("^22^23^24^"[("^"_$P(DGPMA,"^",18)_"^"):$S('$D(^DPT(DFN,"DAC")):"",$L($P(^("DAC"),"^",1)):T,1:""),DGPMN:T,1:"")
.I $P(DR,"//",2)=T S DR=$S("^1^2^"[("^"_DGPMT_"^")&+DGPMA:DR_";S:X'=""S"" Y=0;401.4////"_$P(DGPMA,"."),1:DR)
.S DIE="^DPT(",DA=DFN K DQ,DG D ^DIE K DIE,T,W
I $D(^DPT(DFN,"DAC")) I $L($P(^("DAC"),"^",1)) S DA=DFN,DR=401.3,DIE="^DPT(" K DQ,DG D ^DIE
K DIE,T,W Q
ADM ;update admission or check-in mvt with discharge/check-out mvt pointer
Q
Q:$S('DGPMN:1,'$D(^DGPM(+DGPMCA,0)):1,1:0)
S ^UTILITY("DGPM",$J,1,+DGPMCA,"P")=DGPMAN,^UTILITY("DGPM",$J,1,+DGPMCA,"A")=$G(^DGPM(+DGPMCA,0))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMV33 3375 printed Sep 23, 2025@20:26:12 Page 2
DGPMV33 ;ALB/MIR - DISCHARGE A PATIENT, CONTINUED ; 8/4/03 1:13pm
+1 ;;5.3;Registration;**204,544**;Aug 13, 1993
+2 ;
+3 IF '$PIECE(DGPMA,"^",4)!$SELECT($PIECE(DGPMA,"^",18)'=10:0,'$PIECE(DGPMA,"^",5):1,1:0)
WRITE !,"Incomplete Discharge"
SET DIK="^DGPM("
SET DA=DGPMDA
DO ^DIK
WRITE " deleted"
SET DGPMA=""
Begin DoDot:1
+4 SET ^UTILITY("DGPM",$JOB,3,DA,"A")=$GET(^("P"))
+5 IF $GET(DGPMVI(13))
IF $DATA(^UTILITY("DGPM",$JOB,1,+DGPMVI(13),"A"))
SET $PIECE(^("A"),U,17)=$PIECE($GET(^("P")),U,17)
End DoDot:1
GOTO Q
+6 SET DGPMPTF=$PIECE(DGPMAN,"^",16)
if 'DGPMPTF
GOTO DQ
+7 SET X=$SELECT($DATA(^DG(405.2,+$PIECE(DGPMA,"^",18),0)):$PIECE(^(0),"^",8),1:"")
SET DR=$SELECT(+DGPMA:"70////"_+DGPMA_";",1:"")_$SELECT(X:"72////"_X,1:"")
SET DIE="^DGPT("
SET DA=DGPMPTF
KILL DQ,DG
DO ^DIE
+8 IF +DGPMP=+DGPMA
GOTO Q
DQ SET DGPMER=0
IF $PIECE(DGPMAN,"^",18)=40
DO SET^DGPMV32
IF DGPMAB
SET X1=+DGPMAB
SET X2=30
DO C^%DTC
IF X'<+DGPMA
DO ASIH^DGPMV331
+1 ;I 'DGPMER,$D(^DGPM(+DGPMDA,0)) D ADM
+2 IF DGPMN
DO DIS^DGPMVODS
+3 WRITE !,"Patient Discharge",$SELECT('$DATA(^DGPM(+DGPMDA,0)):" Deleted",DGPMA=DGPMP:"",'DGPMP:"d",1:" Updated")
Q QUIT
DICS ;input transform on discharge type
+1 SET DGX1=$PIECE(^DG(405.1,+Y,0),"^",3)
SET DGSV=$SELECT($DATA(^DIC(42,+$PIECE(DGPM0,"^",6),0)):$PIECE(^(0),"^",3),1:"")
+2 IF DGX1=33
IF $SELECT(DGSV="":1,DGSV'="D":1,1:0)
SET DGER=1
QUIT
+3 IF DGX1=35
IF $SELECT(DGSV="":1,DGSV'="NH":1,1:0)
SET DGER=1
QUIT
+4 IF $SELECT(DGX1=31:1,DGX1=32:1,1:0)
IF $SELECT(DGSV="":0,"NHD"[DGSV:1,1:0)
SET DGER=1
QUIT
+5 IF DGX1=34
IF $SELECT(DGSV="":1,DGSV="NH":1,1:0)
SET DGER=1
QUIT
+6 ;I "^21^47^48^49^"[("^"_DGX1_"^") S DGER=1 Q
+7 IF DGX1=42
IF '$ORDER(^DGPM("ATID2",+$PIECE(^DGPM(DA,0),"^",3),9999999.9999999-^(0)))
SET DGER=1
QUIT
+8 SET DGX=+$PIECE(DGPMP,"^",18)
IF DGX
IF "^41^46^"[("^"_DGX_"^")
IF (DGX1'=DGX)
SET DGER=1
QUIT
+9 IF "^42^47^"[("^"_DGX1_"^")
IF (DGX1'=$PIECE(^DGPM(DA,0),"^",18))
SET DGER=1
QUIT
+10 IF "^42^47^"[("^"_DGX_"^")
IF (DGX1'=$PIECE(^DGPM(DA,0),"^",18))
SET DGER=1
QUIT
+11 IF DGX
IF "^41^42^46^47^"'[("^"_DGX_"^")
IF ("^41^42^46^47^"[("^"_DGX1_"^"))
SET DGER=1
QUIT
+12 ;if admission type is TO ASIH and d/c type is WHILE ASIH
IF $PIECE(DGPMAN,"^",18)=40
IF ("^42^47^"[("^"_DGX1_"^"))
SET DGER=1
QUIT
+13 ;if adm type not TO ASIH and d/c type FROM ASIH or CONTINUED ASIH (O.F.)
IF $PIECE(DGPMAN,"^",18)'=40
IF ("^41^46^"[("^"_DGX1_"^"))
SET DGER=1
QUIT
+14 IF $PIECE(DGPMAN,"^",18)'=40
SET DGER=0
QUIT
+15 IF "^41^46^"'[("^"_DGX1_"^")
SET DGER=0
QUIT
+16 DO SET^DGPMV32
SET X1=+DGPMAB
SET X2=30
SET DGHX=X
DO C^%DTC
IF ^DGPM(DA,0)>X
SET DGER=1
SET X=DGHX
KILL DGHX
QUIT
+17 SET X=DGHX
SET DGER=0
KILL DGHX
+18 ;if discharge from NHCU/DOM is type 47
IF $DATA(^DGPM(+$PIECE(DGPMAN,"^",21),0))
IF $DATA(^DGPM(+$PIECE(^(0),"^",14),0))
IF $DATA(^DGPM(+$PIECE(^(0),"^",17),0))
IF ($PIECE(^(0),"^",18)=47)
SET DGER=1
QUIT
+19 SET DGER=0
QUIT
SI if "^25^26^"[("^"_$PIECE(DGPMA,"^",18)_"^")
QUIT
+1 IF $SELECT('$DATA(^DPT(DFN,.1)):1,^(.1)="":1,1:0)&($DATA(^("DAC")))
SET DR="401.3///@"
SET DIE="^DPT("
SET DA=DFN
KILL DQ,DG
if $PIECE(^("DAC"),"^",1)="S"
DO ^DIE
KILL DR,DIC
QUIT
+2 if '$DATA(^DPT(DFN,.1))
QUIT
SET W=^(.1)
if W']""
QUIT
SET W=$ORDER(^DIC(42,"B",W,0))
SET W=$SELECT($DATA(^DIC(42,+W,0)):^(0),1:"")
SET T="SERIOUSLY ILL"
if W=""
QUIT
+3 IF $PIECE(W,"^",14)
IF ($PIECE(DGPMA,"^",18)>3)
Begin DoDot:1
+4 SET DR="401.3//"_$SELECT("^22^23^24^"[("^"_$PIECE(DGPMA,"^",18)_"^"):$SELECT('$DATA(^DPT(DFN,"DAC")):"",$LENGTH($PIECE(^("DAC"),"^",1)):T,1:""),DGPMN:T,1:"")
+5 IF $PIECE(DR,"//",2)=T
SET DR=$SELECT("^1^2^"[("^"_DGPMT_"^")&+DGPMA:DR_";S:X'=""S"" Y=0;401.4////"_$PIECE(DGPMA,"."),1:DR)
+6 SET DIE="^DPT("
SET DA=DFN
KILL DQ,DG
DO ^DIE
KILL DIE,T,W
End DoDot:1
QUIT
+7 IF $DATA(^DPT(DFN,"DAC"))
IF $LENGTH($PIECE(^("DAC"),"^",1))
SET DA=DFN
SET DR=401.3
SET DIE="^DPT("
KILL DQ,DG
DO ^DIE
+8 KILL DIE,T,W
QUIT
ADM ;update admission or check-in mvt with discharge/check-out mvt pointer
+1 QUIT
+2 if $SELECT('DGPMN
QUIT
+3 SET ^UTILITY("DGPM",$JOB,1,+DGPMCA,"P")=DGPMAN
SET ^UTILITY("DGPM",$JOB,1,+DGPMCA,"A")=$GET(^DGPM(+DGPMCA,0))
+4 QUIT
