- 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 Feb 19, 2025@00:16:28 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