DGPMVDD ;ALB/MIR - MISCELLANEOUS DD CALLS FROM FILE 405 AND 405.1 ; 4/14/04 6:26pm
;;5.3;Registration;**418,593**;Aug 13, 1993
W ;called from input transform for ward location
I '$D(DGPMT) K X,DIC Q
S DGPMTYP=$P(^DGPM(DA,0),"^",18),DGPMWD=$P(DGPMP,"^",6) D W1:DGPMT=1,W2:DGPMT=2!($P(^DGPM(DA,0),"^",2)=2) Q
W1 ;consistency edits for ward location from admit option
I $D(DGPMSVC) S DIC("S")=DIC("S")_","_$S(DGPMSVC="H":"""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")",1:"$P(^(0),""^"",3)=DGPMSVC") Q
S DGX=$P(DGPMP,"^",17) I DGX,(DGPMTYP=40),$S('$D(^DGPM(+DGX,0)):0,+^(0):1,1:0) S DIC("S")="I +Y=DGPMWD" Q
;S DGX="" I DGPMTYP=18 S DIC("S")=DIC("S")_",""^NH^D^""[(""^""_$P(^(0),""^"",3)_""^"")" Q
S DGX="" I DGPMTYP=18 S DIC("S")=DIC("S")_",""^NH^D^""[(""^""_$P(^(0),""^"",3)_""^"")!($P(^(0),""^"",17)=1)" ;p-418
;I (DGPMWD&$S($P(DGPM2,"^",2)=2:1,1:0))!(DGPMTYP=40) S DGX=$S($D(^DIC(42,+DGPMWD,0)):$P(^(0),"^",3),1:""),DGX=$S("^NH^D^"'[("^"_DGX_"^"):"H",1:DGX)
;S DGPMWD="",DGPMTYP=40 ; simulate NOIS REN-0304-60611
I (DGPMWD&$S($P(DGPM2,"^",2)=2:1,1:0))!(DGPMTYP=40) S DGX=$S($D(^DIC(42,+DGPMWD,0)):$P($G(^DIC(42,+DGPMWD,0)),U,3),1:""),DGX=$S("^NH^D^"'[("^"_DGX_"^")&($P($G(^DIC(42,+DGPMWD,0)),U,17)'=1):"H",1:DGX) ;p-418/593
;I DGX]"" S DIC("S")=DIC("S")_",("_$S(DGX="NH":"""^NH^:""[",DGX="D":"""^D^""[",1:"""^NH^D^""'[")_"(""^""_$P(^(0),""^"",3)_""^""))"
ZZ I DGX]"" S DIC("S")=DIC("S")_",("_$S(DGX="NH":"""^NH^:""[",DGX="D":"""^D^""[",1:"""^NH^D^""'[")_"(""^""_$P(^(0),""^"",3)_""^"")&($P(^(0),""^"",17)'=1))" ;p-418
I $P(DGPM2,"^",2)=2&$P(DGPM2,"^",6),'DGPMABL S DIC("S")=DIC("S")_",+Y'=$P(DGPM2,""^"",6)"
Q
W2 ;Ward consistency check for transfer. interward transfers not to same ward. unless ASIH mvt, can't go from hospital to NHCU/DOM, vice versa
;I "^13^44^"[("^"_DGPMTYP_"^") S DIC("S")=DIC("S")_",""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")" Q
I "^13^44^"[("^"_DGPMTYP_"^") S DIC("S")=DIC("S")_",""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")&($P(^(0),U,17)'=1)" Q ;added p-418
S DGX=$S($D(^DGPM(+$P(^DGPM(DA,0),"^",14),0)):$P(^(0),"^",6),1:0),DGX=$S($D(^DIC(42,+DGX,0)):$P(^(0),"^",3),1:"")
N DGRAI S DGRAI=$S(DGX="":"",1:$P(^(0),"^",17)) ;added p-418
;I "^14^43^45^"[("^"_DGPMTYP_"^") S DIC("S")=DIC("S")_",DGX=$P(^(0),""^"",3)" Q
I "^14^43^45^"[("^"_DGPMTYP_"^") D Q ;added p-418
.I DGX="D" S DIC("S")=DIC("S")_",($P(^(0),""^"",3)="""_DGX_""")"
.I DGX="NH"!(DGX="I"&(DGRAI=1)) S DIC("S")=DIC("S")_",""^NH^""[(""^""_$P(^(0),""^"",3)_""^"")!(""^I^""[(""^""_$P(^(0),""^"",3)_""^"")&($P(^(0),""^"",17)=1))" ;added p-418
S DGX=$S($D(^DIC(42,+$P(DGPM0,"^",6),0)):$P(^(0),"^",3),1:"")
S DGRAI=$S(DGX="":"",1:$P(^(0),"^",17)) ;added p-418
;I DGX="D"!(DGX="NH") S DIC("S")=DIC("S")_",($P(^(0),""^"",3)="""_DGX_""")"
I DGX="D"!(DGX="NH")!(DGX="I"&(DGRAI=1)) D
.I DGX="D" S DIC("S")=DIC("S")_",($P(^(0),""^"",3)="""_DGX_""")"
.I DGX="NH"!(DGX="I"&(DGRAI=1)) S DIC("S")=DIC("S")_",""^NH^""[(""^""_$P(^(0),""^"",3)_""^"")!(""^I^""[(""^""_$P(^(0),""^"",3)_""^"")&($P(^(0),""^"",17)=1))" ;added p-418
;I DGX'="D"&(DGX'="NH") S DIC("S")=DIC("S")_",""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")"
I DGX'="D"&(DGX'="NH")&(DGX'="I"!(DGRAI'=1)) D
.S DIC("S")=DIC("S")_",""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")&((""^I^""'[(""^""_$P(^(0),""^"",3)_""^"")!($P(^(0),""^"",17)'=1)))" ;added p-418
I $D(^DG(405.2,+DGPMTYP,"E")),'^("E") S DGX=$S(DGPMABL:0,1:$P(DGPM2,"^",6)),DIC("S")=DIC("S")_",+Y'=DGX,+Y'=$P(DGPM0,""^"",6)"
Q
WARD ;is ward active at time of movement?
S DGPMOS=+^DGPM(DA,0) N D0,X S D0=+Y D WIN^DGPMDDCF I X W !,"Ward inactive at time of movement" S DGOOS=1 Q
Q
ROOM ;is room-bed active at time of movement? - called from input transform of .07 in 405
S DGPMOS=$S('$D(DGSWITCH):+^DGPM(DA,0),1:DT) N D0,X S D0=+Y D RIN^DGPMDDCF I X W !,"Room-bed inactive at time of movement" S DGOOS=1 Q
Q
;
TROC ;is bed occupied when transferring from 1 or 23 movement?
;called from DGPM TRANSFER edit template
;output variables DGPMOC &/or DGOOS
;DGPMOC = 2 if occupied & no more beds on ward, 1 if occupied, 0 if unoccupied
;DGOOS = 1 if inactive (out-of-service), otherwise = 0
S (DGPMOC,DGOOS)=0,DGZ7=$P(DGPM0,"^",7),DGZ6=+$P(DGPM0,"^",6)
F DGPMX=0:0 S DGPMX=$O(^DGPM("ARM",+DGZ7,DGPMX)) Q:DGPMX'>0 I $D(^DGPM(DGPMX,0)),$P(DGPM0,"^",3)'=$P(^DGPM(DGPMX,0),"^",3) S DGPMOC=1
;I 'DGPMOC,$S('$D(^DGPM(+DGPMX,0)):0,'$D(^DG(405.4,DGZ7,"W","B",+$P(DGPM0,"^",6))):1,1:0) S DGPMOC=1
;I DGPMOC S DGOCC=0 D TROCWB I DGOCC=DGB S DGPMOC=2
I 'DGPMOC S DGPMOS=+DGPM0 N D0,X S D0=+DGZ7 D RIN^DGPMDDCF S:X DGOOS=1
K DGB,DGOCC,DGPMX,DGPMOS,I Q
Q
TROCWB ;check if ward still has available beds
S I=0 F DGB=0:1 S I=$O(^DG(405.4,"W",DGZ6,I)) Q:I'>0 I $D(^DGPM("ARM",I)) S DGOCC=DGOCC+1
;
ABSRET ;check absence return date for consistency with movement type
S DGPMX=^DGPM(DA,0),DGPMTYP=$P(DGPMX,"^",18),DGPMRD=X
I DGPMTYP=1 S X1=$P(+DGPMX,".",1),X2=4 D C^%DTC I DGPMRD>X K X W !,"Must be within 4 days"
I DGPMTYP=2 S X1=$P(+DGPMX,".",1),X2=5 D C^%DTC I DGPMRD<X K X W !,"Must be more than 4 days"
I $D(X) S X1=$P(+DGPMX,".",1),X2=30 D C^%DTC I DGPMRD>X K X W !,"Must be within 30 days of transfer"
S:$D(X) X=DGPMRD K DGPMTYP,DGPMX,DGPMRD
Q
;
UARET ;called from DGPM TRANSFER template...default 30 day return from UA
N DGPMX,X,X1,X2,Y
S DGPMX=^DGPM(DA,0)
I $P(DGPMX,"^",18)'=3 S DGPMRET="" Q
S X1=$P(+DGPMX,".",1),X2=30 D C^%DTC S Y=X X ^DD("DD") S DGPMRET=Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMVDD 5462 printed Sep 23, 2025@20:26:19 Page 2
DGPMVDD ;ALB/MIR - MISCELLANEOUS DD CALLS FROM FILE 405 AND 405.1 ; 4/14/04 6:26pm
+1 ;;5.3;Registration;**418,593**;Aug 13, 1993
W ;called from input transform for ward location
+1 IF '$DATA(DGPMT)
KILL X,DIC
QUIT
+2 SET DGPMTYP=$PIECE(^DGPM(DA,0),"^",18)
SET DGPMWD=$PIECE(DGPMP,"^",6)
if DGPMT=1
DO W1
if DGPMT=2!($PIECE(^DGPM(DA,0),"^",2)=2)
DO W2
QUIT
W1 ;consistency edits for ward location from admit option
+1 IF $DATA(DGPMSVC)
SET DIC("S")=DIC("S")_","_$SELECT(DGPMSVC="H":"""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")",1:"$P(^(0),""^"",3)=DGPMSVC")
QUIT
+2 SET DGX=$PIECE(DGPMP,"^",17)
IF DGX
IF (DGPMTYP=40)
IF $SELECT('$DATA(^DGPM(+DGX,0)):0,+^(0):1,1:0)
SET DIC("S")="I +Y=DGPMWD"
QUIT
+3 ;S DGX="" I DGPMTYP=18 S DIC("S")=DIC("S")_",""^NH^D^""[(""^""_$P(^(0),""^"",3)_""^"")" Q
+4 ;p-418
SET DGX=""
IF DGPMTYP=18
SET DIC("S")=DIC("S")_",""^NH^D^""[(""^""_$P(^(0),""^"",3)_""^"")!($P(^(0),""^"",17)=1)"
+5 ;I (DGPMWD&$S($P(DGPM2,"^",2)=2:1,1:0))!(DGPMTYP=40) S DGX=$S($D(^DIC(42,+DGPMWD,0)):$P(^(0),"^",3),1:""),DGX=$S("^NH^D^"'[("^"_DGX_"^"):"H",1:DGX)
+6 ;S DGPMWD="",DGPMTYP=40 ; simulate NOIS REN-0304-60611
+7 ;p-418/593
IF (DGPMWD&$SELECT($PIECE(DGPM2,"^",2)=2:1,1:0))!(DGPMTYP=40)
SET DGX=$SELECT($DATA(^DIC(42,+DGPMWD,0)):$PIECE($GET(^DIC(42,+DGPMWD,0)),U,3),1:"")
SET DGX=$SELECT("^NH^D^"'[("^"_DGX_"^")&($PIECE($GET(^DIC(42,+DGPMWD,0)),U,17)'=1):"H",1:DGX)
+8 ;I DGX]"" S DIC("S")=DIC("S")_",("_$S(DGX="NH":"""^NH^:""[",DGX="D":"""^D^""[",1:"""^NH^D^""'[")_"(""^""_$P(^(0),""^"",3)_""^""))"
ZZ ;p-418
IF DGX]""
SET DIC("S")=DIC("S")_",("_$SELECT(DGX="NH":"""^NH^:""[",DGX="D":"""^D^""[",1:"""^NH^D^""'[")_"(""^""_$P(^(0),""^"",3)_""^"")&($P(^(0),""^"",17)'=1))"
+1 IF $PIECE(DGPM2,"^",2)=2&$PIECE(DGPM2,"^",6)
IF 'DGPMABL
SET DIC("S")=DIC("S")_",+Y'=$P(DGPM2,""^"",6)"
+2 QUIT
W2 ;Ward consistency check for transfer. interward transfers not to same ward. unless ASIH mvt, can't go from hospital to NHCU/DOM, vice versa
+1 ;I "^13^44^"[("^"_DGPMTYP_"^") S DIC("S")=DIC("S")_",""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")" Q
+2 ;added p-418
IF "^13^44^"[("^"_DGPMTYP_"^")
SET DIC("S")=DIC("S")_",""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")&($P(^(0),U,17)'=1)"
QUIT
+3 SET DGX=$SELECT($DATA(^DGPM(+$PIECE(^DGPM(DA,0),"^",14),0)):$PIECE(^(0),"^",6),1:0)
SET DGX=$SELECT($DATA(^DIC(42,+DGX,0)):$PIECE(^(0),"^",3),1:"")
+4 ;added p-418
NEW DGRAI
SET DGRAI=$SELECT(DGX="":"",1:$PIECE(^(0),"^",17))
+5 ;I "^14^43^45^"[("^"_DGPMTYP_"^") S DIC("S")=DIC("S")_",DGX=$P(^(0),""^"",3)" Q
+6 ;added p-418
IF "^14^43^45^"[("^"_DGPMTYP_"^")
Begin DoDot:1
+7 IF DGX="D"
SET DIC("S")=DIC("S")_",($P(^(0),""^"",3)="""_DGX_""")"
+8 ;added p-418
IF DGX="NH"!(DGX="I"&(DGRAI=1))
SET DIC("S")=DIC("S")_",""^NH^""[(""^""_$P(^(0),""^"",3)_""^"")!(""^I^""[(""^""_$P(^(0),""^"",3)_""^"")&($P(^(0),""^"",17)=1))"
End DoDot:1
QUIT
+9 SET DGX=$SELECT($DATA(^DIC(42,+$PIECE(DGPM0,"^",6),0)):$PIECE(^(0),"^",3),1:"")
+10 ;added p-418
SET DGRAI=$SELECT(DGX="":"",1:$PIECE(^(0),"^",17))
+11 ;I DGX="D"!(DGX="NH") S DIC("S")=DIC("S")_",($P(^(0),""^"",3)="""_DGX_""")"
+12 IF DGX="D"!(DGX="NH")!(DGX="I"&(DGRAI=1))
Begin DoDot:1
+13 IF DGX="D"
SET DIC("S")=DIC("S")_",($P(^(0),""^"",3)="""_DGX_""")"
+14 ;added p-418
IF DGX="NH"!(DGX="I"&(DGRAI=1))
SET DIC("S")=DIC("S")_",""^NH^""[(""^""_$P(^(0),""^"",3)_""^"")!(""^I^""[(""^""_$P(^(0),""^"",3)_""^"")&($P(^(0),""^"",17)=1))"
End DoDot:1
+15 ;I DGX'="D"&(DGX'="NH") S DIC("S")=DIC("S")_",""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")"
+16 IF DGX'="D"&(DGX'="NH")&(DGX'="I"!(DGRAI'=1))
Begin DoDot:1
+17 ;added p-418
SET DIC("S")=DIC("S")_",""^NH^D^""'[(""^""_$P(^(0),""^"",3)_""^"")&((""^I^""'[(""^""_$P(^(0),""^"",3)_""^"")!($P(^(0),""^"",17)'=1)))"
End DoDot:1
+18 IF $DATA(^DG(405.2,+DGPMTYP,"E"))
IF '^("E")
SET DGX=$SELECT(DGPMABL:0,1:$PIECE(DGPM2,"^",6))
SET DIC("S")=DIC("S")_",+Y'=DGX,+Y'=$P(DGPM0,""^"",6)"
+19 QUIT
WARD ;is ward active at time of movement?
+1 SET DGPMOS=+^DGPM(DA,0)
NEW D0,X
SET D0=+Y
DO WIN^DGPMDDCF
IF X
WRITE !,"Ward inactive at time of movement"
SET DGOOS=1
QUIT
+2 QUIT
ROOM ;is room-bed active at time of movement? - called from input transform of .07 in 405
+1 SET DGPMOS=$SELECT('$DATA(DGSWITCH):+^DGPM(DA,0),1:DT)
NEW D0,X
SET D0=+Y
DO RIN^DGPMDDCF
IF X
WRITE !,"Room-bed inactive at time of movement"
SET DGOOS=1
QUIT
+2 QUIT
+3 ;
TROC ;is bed occupied when transferring from 1 or 23 movement?
+1 ;called from DGPM TRANSFER edit template
+2 ;output variables DGPMOC &/or DGOOS
+3 ;DGPMOC = 2 if occupied & no more beds on ward, 1 if occupied, 0 if unoccupied
+4 ;DGOOS = 1 if inactive (out-of-service), otherwise = 0
+5 SET (DGPMOC,DGOOS)=0
SET DGZ7=$PIECE(DGPM0,"^",7)
SET DGZ6=+$PIECE(DGPM0,"^",6)
+6 FOR DGPMX=0:0
SET DGPMX=$ORDER(^DGPM("ARM",+DGZ7,DGPMX))
if DGPMX'>0
QUIT
IF $DATA(^DGPM(DGPMX,0))
IF $PIECE(DGPM0,"^",3)'=$PIECE(^DGPM(DGPMX,0),"^",3)
SET DGPMOC=1
+7 ;I 'DGPMOC,$S('$D(^DGPM(+DGPMX,0)):0,'$D(^DG(405.4,DGZ7,"W","B",+$P(DGPM0,"^",6))):1,1:0) S DGPMOC=1
+8 ;I DGPMOC S DGOCC=0 D TROCWB I DGOCC=DGB S DGPMOC=2
+9 IF 'DGPMOC
SET DGPMOS=+DGPM0
NEW D0,X
SET D0=+DGZ7
DO RIN^DGPMDDCF
if X
SET DGOOS=1
+10 KILL DGB,DGOCC,DGPMX,DGPMOS,I
QUIT
+11 QUIT
TROCWB ;check if ward still has available beds
+1 SET I=0
FOR DGB=0:1
SET I=$ORDER(^DG(405.4,"W",DGZ6,I))
if I'>0
QUIT
IF $DATA(^DGPM("ARM",I))
SET DGOCC=DGOCC+1
+2 ;
ABSRET ;check absence return date for consistency with movement type
+1 SET DGPMX=^DGPM(DA,0)
SET DGPMTYP=$PIECE(DGPMX,"^",18)
SET DGPMRD=X
+2 IF DGPMTYP=1
SET X1=$PIECE(+DGPMX,".",1)
SET X2=4
DO C^%DTC
IF DGPMRD>X
KILL X
WRITE !,"Must be within 4 days"
+3 IF DGPMTYP=2
SET X1=$PIECE(+DGPMX,".",1)
SET X2=5
DO C^%DTC
IF DGPMRD<X
KILL X
WRITE !,"Must be more than 4 days"
+4 IF $DATA(X)
SET X1=$PIECE(+DGPMX,".",1)
SET X2=30
DO C^%DTC
IF DGPMRD>X
KILL X
WRITE !,"Must be within 30 days of transfer"
+5 if $DATA(X)
SET X=DGPMRD
KILL DGPMTYP,DGPMX,DGPMRD
+6 QUIT
+7 ;
UARET ;called from DGPM TRANSFER template...default 30 day return from UA
+1 NEW DGPMX,X,X1,X2,Y
+2 SET DGPMX=^DGPM(DA,0)
+3 IF $PIECE(DGPMX,"^",18)'=3
SET DGPMRET=""
QUIT
+4 SET X1=$PIECE(+DGPMX,".",1)
SET X2=30
DO C^%DTC
SET Y=X
XECUTE ^DD("DD")
SET DGPMRET=Y
+5 QUIT
