DGPMV21 ;ALB/MRL/MIR - PASS/FAIL MOVEMENT DATE; 8 MAY 89
;;5.3;Registration;**40,95,131**;Aug 13, 1993;Build 2
I $S('$D(DGPMY):1,DGPMY?7N:0,DGPMY'?7N1".".N:1,1:0) S DGPME="DATE EITHER NOT PASSED OR NOT IN EXPECTED VA FILEMANAGER FORMAT" G Q
I $S('$D(DGPMT):1,'DGPMT:1,1:0) S DGPME="TRANSACTION TYPE IS NOT DEFINED" G Q
D PTF^DGPMV22(DFN,DGPMDA,.DGPME,DGPMCA) G:$G(DGPME)]"" Q K DGPME
G CONT:("^4^5^"[("^"_DGPMT_"^"))!DGPMN D PTF I $D(DGPME),DGPME="***" Q
CONT Q:'DGPMN D CHK I $D(DGPME) G Q
I DGPM1X Q ;Don't ask to add a new one if discharge or check-out
ADD S Y=DGPMY X ^DD("DD")
ADD1 W !!,"SURE YOU WANT TO ADD '",Y,"' AS A NEW ",DGPMUC," DATE" S:"^1^4^"'[("^"_DGPMT_"^") %=1 D YN^DICN Q:%=1 I '% W !?4,"Answer YES if you wish to add this new entry otherwise answer NO!" G ADD1
S DGPME="NOTHING ADDED" G Q
;
CHK ;Check new date/time for consistency with other movements
I $D(^DGPM("APRD",DFN,DGPMY))!$D(^DGPM("APTT6",DFN,DGPMY))!$D(^DGPM("APTT4",DFN,DGPMY))!$D(^DGPM("APTT5",DFN,DGPMY)) S DGPME="There is already a movement at that date/time" Q
I "^1^4^"'[("^"_DGPMT_"^"),(DGPMY<+DGPMAN) S DGPME="Not before "_$S(DGPMT<4:"admission",DGPMT>5:"admission",1:"check-in")_" movement" Q
I "^3^5^"'[("^"_DGPMT_"^"),DGPMCA I DGPMDCD,(DGPMY>DGPMDCD) S DGPME="Not after "_$S(DGPMT<4:"discharge",DGPMT>5:"discharge",1:"check-out")_" movement" Q
I DGPMT=3 S I=$O(^DGPM("APMV",DFN,DGPMCA,0)),I=$O(^(+I,0)) I $D(^DGPM(+I,0)),(+^(0)>DGPMY) S DGPME="Not before last movement" Q
I DGPMT=3 S I=$O(^DGPM("ATS",DFN,DGPMCA,0)),I=$O(^(+I,0)),I=$O(^(+I,0)) I $D(^DGPM(+I,0)),(+^(0)>DGPMY) S DGPME="Not before last movement" Q
I $D(^DGPM(+$P(DGPMAN,"^",21),0)),$D(^DGPM(+$P(^(0),"^",14),0)),$D(^DGPM(+$P(^(0),"^",17),0)) S X=^(0) I $P(X,"^",18)=47,(DGPMY'>+X) S DGPME="Must be after NHCU/DOM discharge" Q
I DGPMT=6,$$CHKLAST^DGPMV30(DFN,DGPMCA,+DGPMY) S DGPME="Cannot change treating specialty while patient is on absence." Q
I "^1^4^"'[("^"_DGPMT_"^") Q
S X=$O(^DGPM("APTT3",DFN,DGPMY)),Y=$O(^DGPM("APTT5",DFN,DGPMY)) I X!Y S DGPME="New "_$S(DGPMT=1:"admission",1:"check-in")_" ...must enter after last "_$S(X:"discharge",1:"check-out") G Q
S DGX=$P(DGPMAN,"^",21) Q:'$D(^DGPM(+DGX,0)) S DGX=^(0),X=$S($D(^DGPM(+$P(DGX,"^",14),0)):^(0),1:"") Q:'X I $D(^DGP(45.84,+$P(X,"^",16))) S DGPME="Can't edit. Corresponding NHCU/DOM PTF Record is Closed." G Q
I $D(^DGPM(+$P(DGPMAN,"^",17),0)),+^(0) S DGPME="After discharge. Must edit movement through NHCU/DOM transfer." G Q
Q
;
;
PTF S PTF=+$P(DGPMAN,"^",16) I $S('PTF:1,'$D(^DGPT(PTF,0)):1,1:0) D NOPTF Q
I $D(^DGP(45.84,PTF)) S DGPME="***" W !,"PTF record is closed for this admission...cannot edit" G Q
Q
;
NOPTF W *7 F I=1:1 S J=$P($T(NP+I),";;",2) Q:J="" W !?4,J
S DGPME="***"
Q S DGPMY=0 Q
;
NP ;
;;WARNING: This admission has no corresponding PTF record.
;;A PTF record is required in order to continue processing
;;this movement activity. If you have the PTF option called
;;"Establish PTF record from Past Admission" on your menu, it
;;may be used to create the PTF record for this admission.
;;Otherwise appropriate Medical Information Section (MIS)
;;personnel and/or your supervisor will need to be notified
;;that the PTF record is missing as soon as possible in order
;;to continue processing this movement.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMV21 3351 printed Dec 13, 2024@02:50:10 Page 2
DGPMV21 ;ALB/MRL/MIR - PASS/FAIL MOVEMENT DATE; 8 MAY 89
+1 ;;5.3;Registration;**40,95,131**;Aug 13, 1993;Build 2
+2 IF $SELECT('$DATA(DGPMY):1,DGPMY?7N:0,DGPMY'?7N1".".N:1,1:0)
SET DGPME="DATE EITHER NOT PASSED OR NOT IN EXPECTED VA FILEMANAGER FORMAT"
GOTO Q
+3 IF $SELECT('$DATA(DGPMT):1,'DGPMT:1,1:0)
SET DGPME="TRANSACTION TYPE IS NOT DEFINED"
GOTO Q
+4 DO PTF^DGPMV22(DFN,DGPMDA,.DGPME,DGPMCA)
if $GET(DGPME)]""
GOTO Q
KILL DGPME
+5 if ("^4^5^"[("^"_DGPMT_"^"))!DGPMN
GOTO CONT
DO PTF
IF $DATA(DGPME)
IF DGPME="***"
QUIT
CONT if 'DGPMN
QUIT
DO CHK
IF $DATA(DGPME)
GOTO Q
+1 ;Don't ask to add a new one if discharge or check-out
IF DGPM1X
QUIT
ADD SET Y=DGPMY
XECUTE ^DD("DD")
ADD1 WRITE !!,"SURE YOU WANT TO ADD '",Y,"' AS A NEW ",DGPMUC," DATE"
if "^1^4^"'[("^"_DGPMT_"^")
SET %=1
DO YN^DICN
if %=1
QUIT
IF '%
WRITE !?4,"Answer YES if you wish to add this new entry otherwise answer NO!"
GOTO ADD1
+1 SET DGPME="NOTHING ADDED"
GOTO Q
+2 ;
CHK ;Check new date/time for consistency with other movements
+1 IF $DATA(^DGPM("APRD",DFN,DGPMY))!$DATA(^DGPM("APTT6",DFN,DGPMY))!$DATA(^DGPM("APTT4",DFN,DGPMY))!$DATA(^DGPM("APTT5",DFN,DGPMY))
SET DGPME="There is already a movement at that date/time"
QUIT
+2 IF "^1^4^"'[("^"_DGPMT_"^")
IF (DGPMY<+DGPMAN)
SET DGPME="Not before "_$SELECT(DGPMT<4:"admission",DGPMT>5:"admission",1:"check-in")_" movement"
QUIT
+3 IF "^3^5^"'[("^"_DGPMT_"^")
IF DGPMCA
IF DGPMDCD
IF (DGPMY>DGPMDCD)
SET DGPME="Not after "_$SELECT(DGPMT<4:"discharge",DGPMT>5:"discharge",1:"check-out")_" movement"
QUIT
+4 IF DGPMT=3
SET I=$ORDER(^DGPM("APMV",DFN,DGPMCA,0))
SET I=$ORDER(^(+I,0))
IF $DATA(^DGPM(+I,0))
IF (+^(0)>DGPMY)
SET DGPME="Not before last movement"
QUIT
+5 IF DGPMT=3
SET I=$ORDER(^DGPM("ATS",DFN,DGPMCA,0))
SET I=$ORDER(^(+I,0))
SET I=$ORDER(^(+I,0))
IF $DATA(^DGPM(+I,0))
IF (+^(0)>DGPMY)
SET DGPME="Not before last movement"
QUIT
+6 IF $DATA(^DGPM(+$PIECE(DGPMAN,"^",21),0))
IF $DATA(^DGPM(+$PIECE(^(0),"^",14),0))
IF $DATA(^DGPM(+$PIECE(^(0),"^",17),0))
SET X=^(0)
IF $PIECE(X,"^",18)=47
IF (DGPMY'>+X)
SET DGPME="Must be after NHCU/DOM discharge"
QUIT
+7 IF DGPMT=6
IF $$CHKLAST^DGPMV30(DFN,DGPMCA,+DGPMY)
SET DGPME="Cannot change treating specialty while patient is on absence."
QUIT
+8 IF "^1^4^"'[("^"_DGPMT_"^")
QUIT
+9 SET X=$ORDER(^DGPM("APTT3",DFN,DGPMY))
SET Y=$ORDER(^DGPM("APTT5",DFN,DGPMY))
IF X!Y
SET DGPME="New "_$SELECT(DGPMT=1:"admission",1:"check-in")_" ...must enter after last "_$SELECT(X:"discharge",1:"check-out")
GOTO Q
+10 SET DGX=$PIECE(DGPMAN,"^",21)
if '$DATA(^DGPM(+DGX,0))
QUIT
SET DGX=^(0)
SET X=$SELECT($DATA(^DGPM(+$PIECE(DGX,"^",14),0)):^(0),1:"")
if 'X
QUIT
IF $DATA(^DGP(45.84,+$PIECE(X,"^",16)))
SET DGPME="Can't edit. Corresponding NHCU/DOM PTF Record is Closed."
GOTO Q
+11 IF $DATA(^DGPM(+$PIECE(DGPMAN,"^",17),0))
IF +^(0)
SET DGPME="After discharge. Must edit movement through NHCU/DOM transfer."
GOTO Q
+12 QUIT
+13 ;
+14 ;
PTF SET PTF=+$PIECE(DGPMAN,"^",16)
IF $SELECT('PTF:1,'$DATA(^DGPT(PTF,0)):1,1:0)
DO NOPTF
QUIT
+1 IF $DATA(^DGP(45.84,PTF))
SET DGPME="***"
WRITE !,"PTF record is closed for this admission...cannot edit"
GOTO Q
+2 QUIT
+3 ;
NOPTF WRITE *7
FOR I=1:1
SET J=$PIECE($TEXT(NP+I),";;",2)
if J=""
QUIT
WRITE !?4,J
+1 SET DGPME="***"
Q SET DGPMY=0
QUIT
+1 ;
NP ;
+1 ;;WARNING: This admission has no corresponding PTF record.
+2 ;;A PTF record is required in order to continue processing
+3 ;;this movement activity. If you have the PTF option called
+4 ;;"Establish PTF record from Past Admission" on your menu, it
+5 ;;may be used to create the PTF record for this admission.
+6 ;;Otherwise appropriate Medical Information Section (MIS)
+7 ;;personnel and/or your supervisor will need to be notified
+8 ;;that the PTF record is missing as soon as possible in order
+9 ;;to continue processing this movement.
