DGPMV10 ;ALB/MRL/MIR - PATIENT MOVEMENT, CONT.; 11 APR 89 ; 4/15/03 5:48pm
;;5.3;Registration;**84,498,509,683,719,1015**;Aug 13, 1993;Build 21
;ihs/cmi/maw 02/08/2012 patch 1014 reinsert IHS code from patch 1001
CS ;Current Status
;first print primary care team/practitioner/attending
D PCMM^SCRPU4(DFN,DT)
S X=$S('DGPMT:1,DGPMT<4:2,DGPMT>5:2,1:3) ;DGPMT=0 if from pt inq (DGRPD)
I '$D(^DGPM("C",DFN)) W !!,"Status : PATIENT HAS NO INPATIENT OR LODGER ACTIVITY IN THE COMPUTER",*7 D CS2 Q
S A=$S("^3^5^"[("^"_+DGPMVI(2)_"^"):0,1:+DGPMVI(2)) W !!,"Status : ",$S('A:"IN",1:""),"ACTIVE ",$S("^4^5^"[("^"_+DGPMVI(2)_"^"):"LODGER",$P(DGPMVI(8),"^",2)["OBSERVATION":"OBSERVATION PATIENT",1:"INPATIENT")
G CS1:'A W "-" S X=+DGPMVI(4) I X=1 W "on PASS" G CS1
I "^2^3^25^26^"[("^"_X_"^") W "on ",$S("^2^26^"[X:"A",1:"U"),"A" G CS1
I "^13^43^44^45^"[("^"_X_"^") W "ASIH" G CS1
I X=6 W "OTHER FAC" G CS1
W "on WARD"
CS1 I +DGPMVI(2)=3,$D(^DGPM(+DGPMVI(17),0)) W ?39,"Discharge Type : ",$S($D(^DG(405.1,+$P(^(0),"^",4),0)):$P(^(0),"^",1),1:"UNKNOWN")
;I "^3^4^5^"'[("^"_+DGPMVI(2)_"^"),$D(^DPT(DFN,"DAC")),($P(^("DAC"),"^",1)="S") W " (Seriously ill)"
;ihs/cmi/maw 02/08/2012 patch 1014 reinsert IHS code
I "^3^4^5^"'[("^"_+DGPMVI(2)_"^") S X=$$GET1^DIQ(2,DFN,401.3) I X]"" W " (",X,")"
W ! I +DGPMVI(19,1) W "Patient chose not to be included in the Facility Directory for this admission"
W !,$S("^4^5^"'[("^"_+DGPMVI(2)_"^"):"Admitted ",1:"Checked-in "),": "_$P(DGPMVI(13,1),"^",2)
W ?39,$S("^4^5^"[("^"_+DGPMVI(2)_"^"):"Checked-out",+DGPMVI(2)=3:"Discharged ",1:"Transferred")," : ",$S("^1^4^"'[("^"_+DGPMVI(2)_"^"):$P(DGPMVI(3),"^",2),$P(DGPMVI(3),"^",2)'=$P(DGPMVI(13,1),"^",2):$P(DGPMVI(3),"^",2),1:"")
;W !,"Ward : ",$E($P(DGPMVI(5),"^",2),1,24),?39,"Room-Bed : ",$E($P(DGPMVI(6),"^",2),1,21) I "^4^5^"'[("^"_+DGPMVI(2)_"^") W !,"Provider : ",$E($P(DGPMVI(7),"^",2),1,26),?39,"Specialty : ",$E($P(DGPMVI(8),"^",2),1,21)
;ihs/cmi/maw 02/08/2012 patch 1014 reinsert IHS code
W !,"Ward : ",$E($P(DGPMVI(5),"^",2),1,24),?39,"Room-Bed/Ext : ",$E($P(DGPMVI(6),"^",2),1,21)_" / "_$$GET1^DIQ(405.4,+DGPMVI(6),9999999.01)
I "^4^5^"'[("^"_+DGPMVI(2)_"^") W !,"Provider : ",$E($P(DGPMVI(7),"^",2),1,26),?39,"Specialty : ",$E($P(DGPMVI(8),"^",2),1,21) W !,"Attending : ",$E($P(DGPMVI(18),"^",2),1,26)
W !,"Attending :",$E($P(DGPMVI(18),"^",2),1,26)
W ?39,"Admitted by :",$E(DGPMVI(9999999.02),1,26)
D CS2
S DGPMIFN=DGPMVI(13) I +DGPMVI(2)'=4&(+DGPMVI(2)'=5) D ^DGPMLOS W !!,"Admission LOS: ",+$P(X,"^",5) ;," Absence days: ",+$P(X,"^",2)," Pass Days: ",+$P(X,"^",3)," ASIH days: ",+$P(X,"^",4) ihs/cmi/maw 02/08/2012 patch 1014 reinsert IHS code
K A,C,I,J,X
Q
;
CS2 ;-- additional fields for admission screen
Q:$$IHS^BDGF ;ihs/cmi/maw 02/08/2012 patch 1014 reinsert IHS code
Q:DGPMT'=1
S DGHOLD=$S($D(^DPT(DFN,0)):^(0),1:"")
W !!,"Religion : ",$S($D(^DIC(13,+$P(DGHOLD,U,8),0)):$E($P(^(0),U),1,24),1:"")
W ?39,"Marital Status : ",$S($D(^DIC(11,+$P(DGHOLD,U,5),0)):$P(^(0),U),1:"")
S DGHOLD=$S($D(^DPT(DFN,.36)):$P(^(.36),U),1:"")
W !,"Eligibility : ",$S($D(^DIC(8,+$P(DGHOLD,U),0)):$P(^(0),U),1:"")
S DGHOLD=$S($D(^DPT(DFN,.361)):^(.361),1:"")
W:$P(DGHOLD,U)]"" " (",$P($P($P(^DD(2,.3611,0),U,3),$P(DGHOLD,U)_":",2),";"),")"
W:$P(DGHOLD,U)']"" " (NOT VERIFIED)"
K DGHOLD
Q
;
LODGER ;set-up necessary variables if getting last lodger episode
;only need 1,2,13,17 - date/time,TT,check-in IFN,check-out IFN
S I=$O(^DGPM("ATID4",DFN,0)),I=$O(^(+I,0))
S X=$S($D(^DGPM(+I,0)):^(0),1:"") I 'X D NULL Q
I $D(^DGPM(+$P(X,"^",17),0)) S (DGPMDCD,DGPMVI(1))=+^(0),DGPMVI(2)=5,DGPMVI(13)=I,DGPMVI(17)=$P(X,"^",17) Q
S (DGPMDCD,DGPMVI(17))="",DGPMVI(1)=+X,DGPMVI(2)=4,DGPMVI(13)=I
Q
NULL S DGPMDCD="" F I=1,2,13,17 S DGPMVI(I)=""
Q
;
INP ;set-up inpt vbls needed (mimic VAIP array)
;
;Called from scheduling, too
;
D NOW^%DTC S (VAX("DAT"),NOW)=%,NOWI=9999999.999999-% I '$D(VAIP("E")) D LAST^VADPT3
F I=1:1:8,13,17 S DGPMVI(I)=""
F I=13,19 S DGPMVI(I,1)=""
S DGPMVI(1)=$S($D(VAIP("E")):VAIP("E"),1:E) ;use ifn of last mvt from VADPT call or one passed from DGPMV
S DGX=$G(^DGPM(+DGPMVI(1),0)),DGPMVI(2)=$P(DGX,"^",2),DGPMVI(4)=$P(DGX,"^",18) S Y=+DGX X ^DD("DD") S DGPMVI(3)=$P(DGX,"^",1)_"^"_Y
S DGPMVI(5)=$P(DGX,"^",6)_"^"_$S($D(^DIC(42,+$P(DGX,"^",6),0)):$P(^(0),"^",1),1:""),DGPMVI(6)=$P(DGX,"^",7)_"^"_$S($D(^DG(405.4,+$P(DGX,"^",7),0)):$P(^(0),"^",1),1:""),DGPMVI(13)=$P(DGX,"^",14)
I "^3^5^"[("^"_DGPMVI(2)_"^") D GETWD ;get from ward if d/c or check-out
S DGX=$G(^DGPM(+DGPMVI(13),0)) I DGX]"" S Y=+DGX X ^DD("DD") S DGPMVI(13,1)=$P(DGX,"^",1)_"^"_Y,DGPMVI(17)=$P(DGX,"^",17) I $D(DGPMSVC) S DGPMSV=$P($G(^DIC(42,+$P(DGX,"^",6),0)),"^",3)
S DGPMDCD=$S($D(^DGPM(+DGPMVI(17),0)):$P(^(0),"^",1),1:"")
S (DGTS,DGPP,DGAP)="" ;t.s., primary care physician, attending
N BDGCA S BDGCA=$P($G(^DGPM(+DGPMVI(1),0)),U,14),DGPMVI(9999999.02)=$$ADMPRV^BDGF1(+BDGCA,DFN,"ADM") ;ihs/cmi/maw 02/08/2012 patch 1014 reinsert IHS code
F I=NOWI:0 S I=$O(^DGPM("ATS",DFN,+DGPMVI(13),I)) Q:'I F J=0:0 S J=$O(^DGPM("ATS",DFN,+DGPMVI(13),I,J)) Q:'J F IFN=0:0 S IFN=$O(^DGPM("ATS",DFN,+DGPMVI(13),I,J,IFN)) Q:'IFN D TS1 G TSQ:DGTS&DGPP&DGAP
TSQ S DGPMVI(7)=DGPP,DGPMVI(8)=DGTS,DGPMVI(18)=DGAP
S DGX=$G(^DGPM(+DGPMVI(13),0)) I $P(DGX,"^",2)=1 D
.S DGX=$G(^DGPM(+DGPMVI(13),"DIR"))
.S DGX=$P(DGX,"^",1)
.I DGX="" S DGX=$S('DGPMDCD:1,(DGPMDCD<3030414.999999):"",1:1) Q:DGX=""
.S DGPMVI(19,1)=DGX_"^"_$$EXTERNAL^DILFD(405,41,,DGX)
D Q^VADPT3 K DGAP,DGPP,DGTS,DGX,IFN
Q
;
TS1 ; set DGTS, DGPP, and DGAP
Q:'$D(^DGPM(IFN,0)) S DGX=^(0)
I 'DGPP,$D(^VA(200,+$P(DGX,"^",8),0)) S Y=$P(DGX,"^",8)_"^"_$P(^(0),"^") S DGPP=Y
I 'DGAP,$D(^VA(200,+$P(DGX,"^",19),0)) S Y=$P(DGX,"^",19)_"^"_$P(^(0),"^") S DGAP=Y
I 'DGTS,$D(^DIC(45.7,+$P(DGX,"^",9),0)) S DGTS=$P(DGX,"^",9)_"^"_$P(^(0),"^")
Q
GETWD ;get the from ward if last mvt is discharge or check-out
I DGPMVI(2)=5 S J=DGPMVI(13) D SETWD Q
F I=0:0 S I=$O(^DGPM("APMV",DFN,DGPMVI(13),I)) Q:'I!+DGPMVI(5) F J=0:0 S J=$O(^DGPM("APMV",DFN,DGPMVI(13),I,J)) Q:'J D SETWD Q:+DGPMVI(5)
Q
;
SETWD ;set ward and room-bed variables for discharge/check-out mvts
S X=$G(^DGPM(J,0))
I $D(^DIC(42,+$P(X,"^",6),0)) S DGPMVI(5)=$P(X,"^",6)_"^"_$P(^(0),"^",1)
I $D(^DG(405.4,+$P(X,"^",7),0)) S DGPMVI(6)=$P(X,"^",7)_"^"_$P(^(0),"^",1)
Q
DGPMV10 ;ALB/MRL/MIR - PATIENT MOVEMENT, CONT.; 11 APR 89 ; 4/15/03 5:48pm
+1 ;;5.3;Registration;**84,498,509,683,719,1015**;Aug 13, 1993;Build 21
+2 ;ihs/cmi/maw 02/08/2012 patch 1014 reinsert IHS code from patch 1001
CS ;Current Status
+1 ;first print primary care team/practitioner/attending
+2 DO PCMM^SCRPU4(DFN,DT)
+3 ;DGPMT=0 if from pt inq (DGRPD)
SET X=$SELECT('DGPMT:1,DGPMT<4:2,DGPMT>5:2,1:3)
+4 IF '$DATA(^DGPM("C",DFN))
WRITE !!,"Status : PATIENT HAS NO INPATIENT OR LODGER ACTIVITY IN THE COMPUTER",*7
DO CS2
QUIT
+5 SET A=$SELECT("^3^5^"[("^"_+DGPMVI(2)_"^"):0,1:+DGPMVI(2))
WRITE !!,"Status : ",$SELECT('A:"IN",1:""),"ACTIVE ",$SELECT("^4^5^"[("^"_+DGPMVI(2)_"^"):"LODGER",$PIECE(DGPMVI(8),"^",2)["OBSERVATION":"OBSERVATION PATIENT",1:"INPATIENT")
+6 IF 'A
GOTO CS1
WRITE "-"
SET X=+DGPMVI(4)
IF X=1
WRITE "on PASS"
GOTO CS1
+7 IF "^2^3^25^26^"[("^"_X_"^")
WRITE "on ",$SELECT("^2^26^"[X:"A",1:"U"),"A"
GOTO CS1
+8 IF "^13^43^44^45^"[("^"_X_"^")
WRITE "ASIH"
GOTO CS1
+9 IF X=6
WRITE "OTHER FAC"
GOTO CS1
+10 WRITE "on WARD"
CS1 IF +DGPMVI(2)=3
IF $DATA(^DGPM(+DGPMVI(17),0))
WRITE ?39,"Discharge Type : ",$SELECT($DATA(^DG(405.1,+$PIECE(^(0),"^",4),0)):$PIECE(^(0),"^",1),1:"UNKNOWN")
+1 ;I "^3^4^5^"'[("^"_+DGPMVI(2)_"^"),$D(^DPT(DFN,"DAC")),($P(^("DAC"),"^",1)="S") W " (Seriously ill)"
+2 ;ihs/cmi/maw 02/08/2012 patch 1014 reinsert IHS code
+3 IF "^3^4^5^"'[("^"_+DGPMVI(2)_"^")
SET X=$$GET1^DIQ(2,DFN,401.3)
IF X]""
WRITE " (",X,")"
+4 WRITE !
IF +DGPMVI(19,1)
WRITE "Patient chose not to be included in the Facility Directory for this admission"
+5 WRITE !,$SELECT("^4^5^"'[("^"_+DGPMVI(2)_"^"):"Admitted ",1:"Checked-in "),": "_$PIECE(DGPMVI(13,1),"^",2)
+6 WRITE ?39,$SELECT("^4^5^"[("^"_+DGPMVI(2)_"^"):"Checked-out",+DGPMVI(2)=3:"Discharged ",1:"Transferred")," : ",$SELECT("^1^4^"'[("^"_+DGPMVI(2)_"^"):$PIECE(DGPMVI(3),"^",2),$PIECE(DGPMVI(3),"^",2)'=$PIECE(DGPMVI(13,1),"^",2):...
... $PIECE(DGPMVI(3),"^",2),1:"")
+7 ;W !,"Ward : ",$E($P(DGPMVI(5),"^",2),1,24),?39,"Room-Bed : ",$E($P(DGPMVI(6),"^",2),1,21) I "^4^5^"'[("^"_+DGPMVI(2)_"^") W !,"Provider : ",$E($P(DGPMVI(7),"^",2),1,26),?39,"Specialty : ",$E($P(DGPMVI(8),"^",2),1,21)
+8 ;ihs/cmi/maw 02/08/2012 patch 1014 reinsert IHS code
+9 WRITE !,"Ward : ",$EXTRACT($PIECE(DGPMVI(5),"^",2),1,24),?39,"Room-Bed/Ext : ",$EXTRACT($PIECE(DGPMVI(6),"^",2),1,21)_" / "_$$GET1^DIQ(405.4,+DGPMVI(6),9999999.01)
+10 IF "^4^5^"'[("^"_+DGPMVI(2)_"^")
WRITE !,"Provider : ",$EXTRACT($PIECE(DGPMVI(7),"^",2),1,26),?39,"Specialty : ",$EXTRACT($PIECE(DGPMVI(8),"^",2),1,21)
WRITE !,"Attending : ",$EXTRACT($PIECE(DGPMVI(18),"^",2),1,26)
+11 WRITE !,"Attending :",$EXTRACT($PIECE(DGPMVI(18),"^",2),1,26)
+12 WRITE ?39,"Admitted by :",$EXTRACT(DGPMVI(9999999.02),1,26)
+13 DO CS2
+14 ;," Absence days: ",+$P(X,"^",2)," Pass Days: ",+$P(X,"^",3)," ASIH days: ",+$P(X,"^",4) ihs/cmi/maw 02/08/2012 patch 1014 reinsert IHS code
SET DGPMIFN=DGPMVI(13)
IF +DGPMVI(2)'=4&(+DGPMVI(2)'=5)
DO ^DGPMLOS
WRITE !!,"Admission LOS: ",+$PIECE(X,"^",5)
+15 KILL A,C,I,J,X
+16 QUIT
+17 ;
CS2 ;-- additional fields for admission screen
+1 ;ihs/cmi/maw 02/08/2012 patch 1014 reinsert IHS code
IF $$IHS^BDGF
QUIT
+2 IF DGPMT'=1
QUIT
+3 SET DGHOLD=$SELECT($DATA(^DPT(DFN,0)):^(0),1:"")
+4 WRITE !!,"Religion : ",$SELECT($DATA(^DIC(13,+$PIECE(DGHOLD,U,8),0)):$EXTRACT($PIECE(^(0),U),1,24),1:"")
+5 WRITE ?39,"Marital Status : ",$SELECT($DATA(^DIC(11,+$PIECE(DGHOLD,U,5),0)):$PIECE(^(0),U),1:"")
+6 SET DGHOLD=$SELECT($DATA(^DPT(DFN,.36)):$PIECE(^(.36),U),1:"")
+7 WRITE !,"Eligibility : ",$SELECT($DATA(^DIC(8,+$PIECE(DGHOLD,U),0)):$PIECE(^(0),U),1:"")
+8 SET DGHOLD=$SELECT($DATA(^DPT(DFN,.361)):^(.361),1:"")
+9 IF $PIECE(DGHOLD,U)]""
WRITE " (",$PIECE($PIECE($PIECE(^DD(2,.3611,0),U,3),$PIECE(DGHOLD,U)_":",2),";"),")"
+10 IF $PIECE(DGHOLD,U)']""
WRITE " (NOT VERIFIED)"
+11 KILL DGHOLD
+12 QUIT
+13 ;
LODGER ;set-up necessary variables if getting last lodger episode
+1 ;only need 1,2,13,17 - date/time,TT,check-in IFN,check-out IFN
+2 SET I=$ORDER(^DGPM("ATID4",DFN,0))
SET I=$ORDER(^(+I,0))
+3 SET X=$SELECT($DATA(^DGPM(+I,0)):^(0),1:"")
IF 'X
DO NULL
QUIT
+4 IF $DATA(^DGPM(+$PIECE(X,"^",17),0))
SET (DGPMDCD,DGPMVI(1))=+^(0)
SET DGPMVI(2)=5
SET DGPMVI(13)=I
SET DGPMVI(17)=$PIECE(X,"^",17)
QUIT
+5 SET (DGPMDCD,DGPMVI(17))=""
SET DGPMVI(1)=+X
SET DGPMVI(2)=4
SET DGPMVI(13)=I
+6 QUIT
NULL SET DGPMDCD=""
FOR I=1,2,13,17
SET DGPMVI(I)=""
+1 QUIT
+2 ;
INP ;set-up inpt vbls needed (mimic VAIP array)
+1 ;
+2 ;Called from scheduling, too
+3 ;
+4 DO NOW^%DTC
SET (VAX("DAT"),NOW)=%
SET NOWI=9999999.999999-%
IF '$DATA(VAIP("E"))
DO LAST^VADPT3
+5 FOR I=1:1:8,13,17
SET DGPMVI(I)=""
+6 FOR I=13,19
SET DGPMVI(I,1)=""
+7 ;use ifn of last mvt from VADPT call or one passed from DGPMV
SET DGPMVI(1)=$SELECT($DATA(VAIP("E")):VAIP("E"),1:E)
+8 SET DGX=$GET(^DGPM(+DGPMVI(1),0))
SET DGPMVI(2)=$PIECE(DGX,"^",2)
SET DGPMVI(4)=$PIECE(DGX,"^",18)
SET Y=+DGX
XECUTE ^DD("DD")
SET DGPMVI(3)=$PIECE(DGX,"^",1)_"^"_Y
+9 SET DGPMVI(5)=$PIECE(DGX,"^",6)_"^"_$SELECT($DATA(^DIC(42,+$PIECE(DGX,"^",6),0)):$PIECE(^(0),"^",1),1:"")
SET DGPMVI(6)=$PIECE(DGX,"^",7)_"^"_$SELECT($DATA(^DG(405.4,+$PIECE(DGX,"^",7),0)):$PIECE(^(0),"^",1),1:"")
SET DGPMVI(13)=$PIECE(DGX,"^",14)
+10 ;get from ward if d/c or check-out
IF "^3^5^"[("^"_DGPMVI(2)_"^")
DO GETWD
+11 SET DGX=$GET(^DGPM(+DGPMVI(13),0))
IF DGX]""
SET Y=+DGX
XECUTE ^DD("DD")
SET DGPMVI(13,1)=$PIECE(DGX,"^",1)_"^"_Y
SET DGPMVI(17)=$PIECE(DGX,"^",17)
IF $DATA(DGPMSVC)
SET DGPMSV=$PIECE($GET(^DIC(42,+$PIECE(DGX,"^",6),0)),"^",3)
+12 SET DGPMDCD=$SELECT($DATA(^DGPM(+DGPMVI(17),0)):$PIECE(^(0),"^",1),1:"")
+13 ;t.s., primary care physician, attending
SET (DGTS,DGPP,DGAP)=""
+14 ;ihs/cmi/maw 02/08/2012 patch 1014 reinsert IHS code
NEW BDGCA
SET BDGCA=$PIECE($GET(^DGPM(+DGPMVI(1),0)),U,14)
SET DGPMVI(9999999.02)=$$ADMPRV^BDGF1(+BDGCA,DFN,"ADM")
+15 FOR I=NOWI:0
SET I=$ORDER(^DGPM("ATS",DFN,+DGPMVI(13),I))
IF 'I
QUIT
FOR J=0:0
SET J=$ORDER(^DGPM("ATS",DFN,+DGPMVI(13),I,J))
IF 'J
QUIT
FOR IFN=0:0
SET IFN=$ORDER(^DGPM("ATS",DFN,+DGPMVI(13),I,J,IFN))
IF 'IFN
QUIT
DO TS1
IF DGTS&DGPP&DGAP
GOTO TSQ
TSQ SET DGPMVI(7)=DGPP
SET DGPMVI(8)=DGTS
SET DGPMVI(18)=DGAP
+1 SET DGX=$GET(^DGPM(+DGPMVI(13),0))
IF $PIECE(DGX,"^",2)=1
Begin DoDot:1
+2 SET DGX=$GET(^DGPM(+DGPMVI(13),"DIR"))
+3 SET DGX=$PIECE(DGX,"^",1)
+4 IF DGX=""
SET DGX=$SELECT('DGPMDCD:1,(DGPMDCD<3030414.999999):"",1:1)
IF DGX=""
QUIT
+5 SET DGPMVI(19,1)=DGX_"^"_$$EXTERNAL^DILFD(405,41,,DGX)
End DoDot:1
+6 DO Q^VADPT3
KILL DGAP,DGPP,DGTS,DGX,IFN
+7 QUIT
+8 ;
TS1 ; set DGTS, DGPP, and DGAP
+1 IF '$DATA(^DGPM(IFN,0))
QUIT
SET DGX=^(0)
+2 IF 'DGPP
IF $DATA(^VA(200,+$PIECE(DGX,"^",8),0))
SET Y=$PIECE(DGX,"^",8)_"^"_$PIECE(^(0),"^")
SET DGPP=Y
+3 IF 'DGAP
IF $DATA(^VA(200,+$PIECE(DGX,"^",19),0))
SET Y=$PIECE(DGX,"^",19)_"^"_$PIECE(^(0),"^")
SET DGAP=Y
+4 IF 'DGTS
IF $DATA(^DIC(45.7,+$PIECE(DGX,"^",9),0))
SET DGTS=$PIECE(DGX,"^",9)_"^"_$PIECE(^(0),"^")
+5 QUIT
GETWD ;get the from ward if last mvt is discharge or check-out
+1 IF DGPMVI(2)=5
SET J=DGPMVI(13)
DO SETWD
QUIT
+2 FOR I=0:0
SET I=$ORDER(^DGPM("APMV",DFN,DGPMVI(13),I))
IF 'I!+DGPMVI(5)
QUIT
FOR J=0:0
SET J=$ORDER(^DGPM("APMV",DFN,DGPMVI(13),I,J))
IF 'J
QUIT
DO SETWD
IF +DGPMVI(5)
QUIT
+3 QUIT
+4 ;
SETWD ;set ward and room-bed variables for discharge/check-out mvts
+1 SET X=$GET(^DGPM(J,0))
+2 IF $DATA(^DIC(42,+$PIECE(X,"^",6),0))
SET DGPMVI(5)=$PIECE(X,"^",6)_"^"_$PIECE(^(0),"^",1)
+3 IF $DATA(^DG(405.4,+$PIECE(X,"^",7),0))
SET DGPMVI(6)=$PIECE(X,"^",7)_"^"_$PIECE(^(0),"^",1)
+4 QUIT
