- 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 Jan 18, 2025@03:50:51 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.