DGPMV30 ;ALB/MIR - EDITS FOR DATE/TIME ;12 NOV 89 @8
;;5.3;Registration;**95,131**;Aug 13, 1993
CHK ;Check new date/time for consistency with other movements
I DGPMT=6,$P(^DGPM(DGPMDA,0),U,14)=$P(^DGPM(DGPMDA,0),U,24),+Y'=+^DGPM(DGPMCA,0) S DGPME="Cannot change date/time for treating specialty associated with admission." Q
I $D(^DGPM("APRD",DFN,+Y))!$D(^DGPM("APTT6",DFN,+Y))!$D(^DGPM("APTT4",DFN,+Y))!$D(^DGPM("APTT5",DFN,+Y)) S DGPME="There is already a movement at that date/time entered for this patient" Q
S X1=$O(^DGPM("APRD",DFN,+DGPMP+.0000005)) I X1 S X=$O(^DGPM("APRD",DFN,X1,0)) I X,$D(^DGPM(+X,0)) S Z=^(0),X=$P(Z,"^",2) I Y>Z D WR S DGPME=" "_DGPMUC_" must be before next movement." Q
S X1=$O(^DGPM("APTT4",DFN,+DGPMP+.0000005)) I X1 S X=$O(^DGPM("APTT4",DFN,X1,0)) I X,$D(^DGPM(+X,0)) S Z=^(0),X=$P(Z,"^",2) I Y>Z D WR S DGPME=" "_DGPMUC_" must be before next movement." Q
S X1=10000000-DGPMP,X1=$O(^DGPM("APID",DFN,X1)) I X1 S X=$O(^DGPM("APID",DFN,X1,0)) I X,$D(^DGPM(+X,0)) S Z=^(0),X=$P(Z,"^",2) I Y<Z D WR S DGPME=" "_DGPMUC_" must be after last movement." Q
S X1=10000000-DGPMP,X1=$O(^DGPM("ATID5",DFN,X1)) I X1 S X=$O(^DGPM("ATID5",DFN,X1,0)) I X,$D(^DGPM(+X,0)) S Z=^(0),X=$P(Z,"^",2) I Y<Z D WR S DGPME=" "_DGPMUC_" must be after last movement." Q
I DGPMT=6,$$CHKLAST(DFN,DGPMCA,+Y,+DGPMP) S DGPME="Cannot change treating specialty while patient is on absence." Q
I DGPMT=6 N DGXTS S DGXTS=$$CHKTS(DFN,+DGPMP,+Y) I DGXTS S DGPME="Cannot change date/time to "_$S(DGXTS=1:"before previous",1:"after next")_" treating specialty change." Q
S D0=$P(DGPMP,"^",6) I D0 S DGPMOS=+DGPMP D WIN^DGPMDDCF I X S DGPME="Ward was inactive on this date." Q
S D0=$P(DGPMP,"^",7) I D0 S DGPMOS=+DGPMP D RIN^DGPMDDCF I X S DGPME="Room-bed was inactive on this date." Q
I DGPMT=4!(DGPMT=5) Q
S DGPMTYP=$P(DGPMP,"^",18)
;I DGPMTYP=40 D ASIHADM^DGPMV300
I "^41^46^"[("^"_DGPMTYP_"^") S DGPME="Edit through corresponding NHCU/DOM transfer or discharge" Q
;if first transfer to ASIH, make sure it remains within 30 days of return
S K=0 I "^13^43^"[("^"_DGPMTYP_"^") F I=0:0 S I=$O(^DGPM("APCA",DFN,DGPMCA,I)) Q:'I I $D(^DGPM(+$O(^(I,0)),0)),("^14^42^47^"[("^"_$P(^(0),"^",18)_"^")) S K=+^(0) S:K>DGNOW K=DGNOW Q
I K S X1=+DGPMY,X2=30 D C^%DTC I X<K S DGPME="Transfer must be within 30 days of return from ASIH" Q
I $P(DGPMAN,"^",21) D SET^DGPMV32 S X1=+DGPMAB,X2=30 D C^%DTC I DGPMP>X,DGPMY'>X S DGPME="Delete and redo discharge for less than 30 days" Q
I DGPMP'>X,DGPMY>X S DGPME="Delete and redo discharge for greater than 30 days" Q
; no edit of d/t of adm mvt if census rec exist
I DGPMT=1,$O(^DGPT("ACENSUS",+$P(DGPMAN,"^",16),0)) S DGPME="Cannot change admission date/time while PTF Census record #"_$O(^(0))_" is closed" Q
;
I DGPMTYP=42,(DGPMP'>DGPMY) S DGPME="Must be prior to original discharge date/time" Q
Q:(DGPMTYP'=42)
;No edit if hospital admission discharged...must back out
S X=$O(^DGPM("APMV",DFN,DGPMCA,+DGPMP)),X=$O(^(+X,0)) I $D(^DGPM(+X,0)),("^13^44^"[$P(^(0),"^",18)),$D(^DGPM($P(^(0),"^",15),0)),$P(^(0),"^",17) S DGPME="Patient discharged from hospital...no edit of NHCU/DOM discharge allowed" Q
ASK W !!?5,"WARNING: By changing the date/time of this 'WHILE ASIH' discharge,",!?15,"you are permanently discharging this patient from the NHCU/DOM"
W !?15,"prior to the 30 days of ASIH allotted. The patient can not be",!?15,"returned to the NHCU/DOM except by readmission.",!!?15,"Are you sure you want to continue" S %=2 D YN^DICN I %<0 S DGPME="" Q
I '% W !!?5,"Enter 'Y'es to discharge the patient from the NHCU/DOM or 'N'o to",!?15,"continue patient's ASIH stay." G ASK
I %=2 S DGPMY=+DGPMP W !?5,*7,"NO CHANGE TO DATE/TIME MADE" Q
S DGMAS=47 D FAMT I 'DGFAC H 5 G H^XUS
S DIE="^DGPM(",DA=DGPMDA,DR=".04////"_DGFAC D ^DIE K DGFAC
Q
WR W !,*7," There is a",$S(X=1:"n admission",X=2:" transfer",X=3:" discharge",X=4:" check-in lodger",X=5:" check-out lodger",X=6:" specialty transfer",1:"")," movement on file for this patient on " S X=Y,Y=+Z X ^DD("DD") W Y,"." S Y=X
Q
;
FAMT ;find active movement type
;
;input: DGMAS = IFN of 405.2 entry
;output: DGFAC = IFN of active 405.1 entry
;
N I S DGFAC=""
F I=0:0 S I=$O(^DG(405.1,"AM",DGMAS,I)) Q:'I I $D(^DG(405.1,+I,0)),$P(^(0),"^",4) S DGFAC=I Q
I 'DGFAC W !!,"You ASIH movement types are not properly defined...Contact your site manager!","There is no movement type define for ",$P(^DG(405.2,DGMAS,0),"^",1)
K DGMAS
Q
;
CHKLAST(DFN,DGCA,DGY,DGP) ;Function to confirm that patient is not on absence for time/date selected for TS transfer
;
;Input DFN
; DGCA - Corres. Adm.
; DGY - Time/Date being checked
; DGP - date/time before editing
;
;Output 0 - Pt. not on Absence
; 1 - Pt. on Absence
;
N DGFAC,DGMAS,DGX,DGX0,DGZ,X
S X=0,DGX=$O(^DGPM("APCA",DFN,DGCA,DGY),-1),DGZ=$O(^(DGX,0)),DGX0=$P(^DGPM(DGZ,0),U,4)
S DGMAS=20 D FAMT
I '$D(^DG(405.1,+DGFAC,"F",DGX0)) S X=1
I +$G(DGP)=DGY S X=0
Q X
;
CHKTS(DFN,DGP,DGY) ;check previous and next ts transfer date/time
;Output : 0 = acceptable
; 1 = before previous ts change
; 2 = after next ts change
N DGTS1,DGTS2,X
S X=0
S DGTS1=$O(^DGPM("APTT6",DFN,DGP),-1) I DGY'>DGTS1 S X=1 G CHKTSQ
S DGTS2=$O(^DGPM("APTT6",DFN,DGP)) I DGTS2,DGY'<DGTS2 S X=2
CHKTSQ Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMV30 5377 printed Dec 13, 2024@02:50:13 Page 2
DGPMV30 ;ALB/MIR - EDITS FOR DATE/TIME ;12 NOV 89 @8
+1 ;;5.3;Registration;**95,131**;Aug 13, 1993
CHK ;Check new date/time for consistency with other movements
+1 IF DGPMT=6
IF $PIECE(^DGPM(DGPMDA,0),U,14)=$PIECE(^DGPM(DGPMDA,0),U,24)
IF +Y'=+^DGPM(DGPMCA,0)
SET DGPME="Cannot change date/time for treating specialty associated with admission."
QUIT
+2 IF $DATA(^DGPM("APRD",DFN,+Y))!$DATA(^DGPM("APTT6",DFN,+Y))!$DATA(^DGPM("APTT4",DFN,+Y))!$DATA(^DGPM("APTT5",DFN,+Y))
SET DGPME="There is already a movement at that date/time entered for this patient"
QUIT
+3 SET X1=$ORDER(^DGPM("APRD",DFN,+DGPMP+.0000005))
IF X1
SET X=$ORDER(^DGPM("APRD",DFN,X1,0))
IF X
IF $DATA(^DGPM(+X,0))
SET Z=^(0)
SET X=$PIECE(Z,"^",2)
IF Y>Z
DO WR
SET DGPME=" "_DGPMUC_" must be before next movement."
QUIT
+4 SET X1=$ORDER(^DGPM("APTT4",DFN,+DGPMP+.0000005))
IF X1
SET X=$ORDER(^DGPM("APTT4",DFN,X1,0))
IF X
IF $DATA(^DGPM(+X,0))
SET Z=^(0)
SET X=$PIECE(Z,"^",2)
IF Y>Z
DO WR
SET DGPME=" "_DGPMUC_" must be before next movement."
QUIT
+5 SET X1=10000000-DGPMP
SET X1=$ORDER(^DGPM("APID",DFN,X1))
IF X1
SET X=$ORDER(^DGPM("APID",DFN,X1,0))
IF X
IF $DATA(^DGPM(+X,0))
SET Z=^(0)
SET X=$PIECE(Z,"^",2)
IF Y<Z
DO WR
SET DGPME=" "_DGPMUC_" must be after last movement."
QUIT
+6 SET X1=10000000-DGPMP
SET X1=$ORDER(^DGPM("ATID5",DFN,X1))
IF X1
SET X=$ORDER(^DGPM("ATID5",DFN,X1,0))
IF X
IF $DATA(^DGPM(+X,0))
SET Z=^(0)
SET X=$PIECE(Z,"^",2)
IF Y<Z
DO WR
SET DGPME=" "_DGPMUC_" must be after last movement."
QUIT
+7 IF DGPMT=6
IF $$CHKLAST(DFN,DGPMCA,+Y,+DGPMP)
SET DGPME="Cannot change treating specialty while patient is on absence."
QUIT
+8 IF DGPMT=6
NEW DGXTS
SET DGXTS=$$CHKTS(DFN,+DGPMP,+Y)
IF DGXTS
SET DGPME="Cannot change date/time to "_$SELECT(DGXTS=1:"before previous",1:"after next")_" treating specialty change."
QUIT
+9 SET D0=$PIECE(DGPMP,"^",6)
IF D0
SET DGPMOS=+DGPMP
DO WIN^DGPMDDCF
IF X
SET DGPME="Ward was inactive on this date."
QUIT
+10 SET D0=$PIECE(DGPMP,"^",7)
IF D0
SET DGPMOS=+DGPMP
DO RIN^DGPMDDCF
IF X
SET DGPME="Room-bed was inactive on this date."
QUIT
+11 IF DGPMT=4!(DGPMT=5)
QUIT
+12 SET DGPMTYP=$PIECE(DGPMP,"^",18)
+13 ;I DGPMTYP=40 D ASIHADM^DGPMV300
+14 IF "^41^46^"[("^"_DGPMTYP_"^")
SET DGPME="Edit through corresponding NHCU/DOM transfer or discharge"
QUIT
+15 ;if first transfer to ASIH, make sure it remains within 30 days of return
+16 SET K=0
IF "^13^43^"[("^"_DGPMTYP_"^")
FOR I=0:0
SET I=$ORDER(^DGPM("APCA",DFN,DGPMCA,I))
if 'I
QUIT
IF $DATA(^DGPM(+$ORDER(^(I,0)),0))
IF ("^14^42^47^"[("^"_$PIECE(^(0),"^",18)_"^"))
SET K=+^(0)
if K>DGNOW
SET K=DGNOW
QUIT
+17 IF K
SET X1=+DGPMY
SET X2=30
DO C^%DTC
IF X<K
SET DGPME="Transfer must be within 30 days of return from ASIH"
QUIT
+18 IF $PIECE(DGPMAN,"^",21)
DO SET^DGPMV32
SET X1=+DGPMAB
SET X2=30
DO C^%DTC
IF DGPMP>X
IF DGPMY'>X
SET DGPME="Delete and redo discharge for less than 30 days"
QUIT
+19 IF DGPMP'>X
IF DGPMY>X
SET DGPME="Delete and redo discharge for greater than 30 days"
QUIT
+20 ; no edit of d/t of adm mvt if census rec exist
+21 IF DGPMT=1
IF $ORDER(^DGPT("ACENSUS",+$PIECE(DGPMAN,"^",16),0))
SET DGPME="Cannot change admission date/time while PTF Census record #"_$ORDER(^(0))_" is closed"
QUIT
+22 ;
+23 IF DGPMTYP=42
IF (DGPMP'>DGPMY)
SET DGPME="Must be prior to original discharge date/time"
QUIT
+24 if (DGPMTYP'=42)
QUIT
+25 ;No edit if hospital admission discharged...must back out
+26 SET X=$ORDER(^DGPM("APMV",DFN,DGPMCA,+DGPMP))
SET X=$ORDER(^(+X,0))
IF $DATA(^DGPM(+X,0))
IF ("^13^44^"[$PIECE(^(0),"^",18))
IF $DATA(^DGPM($PIECE(^(0),"^",15),0))
IF $PIECE(^(0),"^",17)
SET DGPME="Patient discharged from hospital...no edit of NHCU/DOM discharge allowed"
QUIT
ASK WRITE !!?5,"WARNING: By changing the date/time of this 'WHILE ASIH' discharge,",!?15,"you are permanently discharging this patient from the NHCU/DOM"
+1 WRITE !?15,"prior to the 30 days of ASIH allotted. The patient can not be",!?15,"returned to the NHCU/DOM except by readmission.",!!?15,"Are you sure you want to continue"
SET %=2
DO YN^DICN
IF %<0
SET DGPME=""
QUIT
+2 IF '%
WRITE !!?5,"Enter 'Y'es to discharge the patient from the NHCU/DOM or 'N'o to",!?15,"continue patient's ASIH stay."
GOTO ASK
+3 IF %=2
SET DGPMY=+DGPMP
WRITE !?5,*7,"NO CHANGE TO DATE/TIME MADE"
QUIT
+4 SET DGMAS=47
DO FAMT
IF 'DGFAC
HANG 5
GOTO H^XUS
+5 SET DIE="^DGPM("
SET DA=DGPMDA
SET DR=".04////"_DGFAC
DO ^DIE
KILL DGFAC
+6 QUIT
WR WRITE !,*7," There is a",$SELECT(X=1:"n admission",X=2:" transfer",X=3:" discharge",X=4:" check-in lodger",X=5:" check-out lodger",X=6:" specialty transfer",1:"")," movement on file for this patient on "
SET X=Y
SET Y=+Z
XECUTE ^DD("DD")
WRITE Y,"."
SET Y=X
+1 QUIT
+2 ;
FAMT ;find active movement type
+1 ;
+2 ;input: DGMAS = IFN of 405.2 entry
+3 ;output: DGFAC = IFN of active 405.1 entry
+4 ;
+5 NEW I
SET DGFAC=""
+6 FOR I=0:0
SET I=$ORDER(^DG(405.1,"AM",DGMAS,I))
if 'I
QUIT
IF $DATA(^DG(405.1,+I,0))
IF $PIECE(^(0),"^",4)
SET DGFAC=I
QUIT
+7 IF 'DGFAC
WRITE !!,"You ASIH movement types are not properly defined...Contact your site manager!","There is no movement type define for ",$PIECE(^DG(405.2,DGMAS,0),"^",1)
+8 KILL DGMAS
+9 QUIT
+10 ;
CHKLAST(DFN,DGCA,DGY,DGP) ;Function to confirm that patient is not on absence for time/date selected for TS transfer
+1 ;
+2 ;Input DFN
+3 ; DGCA - Corres. Adm.
+4 ; DGY - Time/Date being checked
+5 ; DGP - date/time before editing
+6 ;
+7 ;Output 0 - Pt. not on Absence
+8 ; 1 - Pt. on Absence
+9 ;
+10 NEW DGFAC,DGMAS,DGX,DGX0,DGZ,X
+11 SET X=0
SET DGX=$ORDER(^DGPM("APCA",DFN,DGCA,DGY),-1)
SET DGZ=$ORDER(^(DGX,0))
SET DGX0=$PIECE(^DGPM(DGZ,0),U,4)
+12 SET DGMAS=20
DO FAMT
+13 IF '$DATA(^DG(405.1,+DGFAC,"F",DGX0))
SET X=1
+14 IF +$GET(DGP)=DGY
SET X=0
+15 QUIT X
+16 ;
CHKTS(DFN,DGP,DGY) ;check previous and next ts transfer date/time
+1 ;Output : 0 = acceptable
+2 ; 1 = before previous ts change
+3 ; 2 = after next ts change
+4 NEW DGTS1,DGTS2,X
+5 SET X=0
+6 SET DGTS1=$ORDER(^DGPM("APTT6",DFN,DGP),-1)
IF DGY'>DGTS1
SET X=1
GOTO CHKTSQ
+7 SET DGTS2=$ORDER(^DGPM("APTT6",DFN,DGP))
IF DGTS2
IF DGY'<DGTS2
SET X=2
CHKTSQ QUIT X
