- DGPMV33 ;ALB/MIR - DISCHARGE A PATIENT, CONTINUED ; 8/4/03 1:13pm
- ;;5.3;Registration;**204,544,1015**;Aug 13, 1993;Build 21
- ;IHS/ANMC/LJF 3/09/2001 bypassed PTF code
- ; 3/28/2001 insured SI/DNR deleted at discharge
- ; 7/27/2001 added check for DGQUIET to writes
- ;
- ;
- ;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 ;IHS/ANMC/LJF 7/27/2001
- I '$P(DGPMA,"^",4)!$S($P(DGPMA,"^",18)'=10:0,'$P(DGPMA,"^",5):1,1:0) W:'$D(DGQUIET) !,"Incomplete Discharge" S DIK="^DGPM(",DA=DGPMDA D ^DIK W " deleted" S DGPMA="" D G Q ;IHS/ANMC/LJF 7/27/2001
- .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") ;IHS/ANMC/LJF 7/27/2001
- W:'$D(DGQUIET) !,"Patient Discharge",$S('$D(^DGPM(+DGPMDA,0)):" Deleted",DGPMA=DGPMP:"",'DGPMP:"d",1:" Updated") ;IHS/ANMC/LJF 7/27/2001
- 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 ;IHS/ANMC/LJF 3/28/2001
- 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)]"" K DR,DIC Q ;IHS/ANMC/LJF 3/28/2001
- Q:$D(DGQUIET) ;IHS/ANMC/LJF 12/3/2001 to prevent talk
- 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
- DGPMV33 ;ALB/MIR - DISCHARGE A PATIENT, CONTINUED ; 8/4/03 1:13pm
- +1 ;;5.3;Registration;**204,544,1015**;Aug 13, 1993;Build 21
- +2 ;IHS/ANMC/LJF 3/09/2001 bypassed PTF code
- +3 ; 3/28/2001 insured SI/DNR deleted at discharge
- +4 ; 7/27/2001 added check for DGQUIET to writes
- +5 ;
- +6 ;
- +7 ;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 ;IHS/ANMC/LJF 7/27/2001
- +8 ;IHS/ANMC/LJF 7/27/2001
- IF '$PIECE(DGPMA,"^",4)!$SELECT($PIECE(DGPMA,"^",18)'=10:0,'$PIECE(DGPMA,"^",5):1,1:0)
- IF '$DATA(DGQUIET)
- WRITE !,"Incomplete Discharge"
- SET DIK="^DGPM("
- SET DA=DGPMDA
- DO ^DIK
- WRITE " deleted"
- SET DGPMA=""
- Begin DoDot:1
- +9 SET ^UTILITY("DGPM",$JOB,3,DA,"A")=$GET(^("P"))
- +10 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
- +11 ;S DGPMPTF=$P(DGPMAN,"^",16) G DQ:'DGPMPTF
- +12 ;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
- +13 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 ;W !,"Patient Discharge",$S('$D(^DGPM(+DGPMDA,0)):" Deleted",DGPMA=DGPMP:"",'DGPMP:"d",1:" Updated") ;IHS/ANMC/LJF 7/27/2001
- +4 ;IHS/ANMC/LJF 7/27/2001
- IF '$DATA(DGQUIET)
- 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 ;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 ;IHS/ANMC/LJF 3/28/2001
- +2 ;IHS/ANMC/LJF 3/28/2001
- 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)]""
- DO ^DIE
- KILL DR,DIC
- QUIT
- +3 ;IHS/ANMC/LJF 12/3/2001 to prevent talk
- IF $DATA(DGQUIET)
- QUIT
- +4 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
- +5 IF $PIECE(W,"^",14)
- IF ($PIECE(DGPMA,"^",18)>3)
- Begin DoDot:1
- +6 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:"")
- +7 IF $PIECE(DR,"//",2)=T
- SET DR=$SELECT("^1^2^"[("^"_DGPMT_"^")&+DGPMA:DR_";S:X'=""S"" Y=0;401.4////"_$PIECE(DGPMA,"."),1:DR)
- +8 SET DIE="^DPT("
- SET DA=DFN
- KILL DQ,DG
- DO ^DIE
- KILL DIE,T,W
- End DoDot:1
- QUIT
- +9 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
- +10 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
