DGPTTS0 ;ALB/MTC - UPDATE FACILITY TREATING SPECIALTY/501 MOVEMENTS IN PTF ; 1/30/90 @12
;;5.3;Registration;;Aug 13, 1993
;
EV ;entry point from event driver
I '$D(^UTILITY("DGPM",$J,6)),'$D(^(3)) Q
N DGPMCA,DGPMAN,PTF,DGADM D CA^DGPTTS
I DGMVT=3 D LE^DGPTTS G Q1
I '$D(^UTILITY("DGPM",$J,6)) G Q1
S DGMV=$O(^UTILITY("DGPM",$J,6,0)),DGMVP=^(DGMV,"P"),DGMVA=^("A")
I DGMVT=1,DGPMP="" S DGNEW=""
I DGMVT=2,DGPMP="","^13^44^"[("^"_$P(DGPMA,"^",18)_"^") S DGNEW=""
G Q1:'$D(^DGPT(+PTF,0))
I DGMVP="",(9999999.999999-DGMVA)'=$E($O(^DGPM("ATS",DFN,DGPMCA,0)),1,14) D NTR^DGPTTS,LE^DGPTTS G Q1
I DGMVA="",DGMVT'=1 D DEL^DGPTTS,LE^DGPTTS G Q1
I ^UTILITY("DGPM",$J,6,DGMV,"DXP")'=^("DXA") S DGMVDA=DGPMDA,DGPMDA=DGMV S:$D(DGNEW) DGMSG1="New Admission" D MOV^DGPTMSG1 S DGPMDA=DGMVDA
D LE^DGPTTS
Q1 K DGMVDA,DGMV,DGMVP,DGMVA,DGMVT,X,V,DGNEW,AGE,DGLAST,DGNEXT,DGY,DOB,DQ,DRG,SEX
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTTS0 907 printed Oct 16, 2024@18:54:17 Page 2
DGPTTS0 ;ALB/MTC - UPDATE FACILITY TREATING SPECIALTY/501 MOVEMENTS IN PTF ; 1/30/90 @12
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
EV ;entry point from event driver
+1 IF '$DATA(^UTILITY("DGPM",$JOB,6))
IF '$DATA(^(3))
QUIT
+2 NEW DGPMCA,DGPMAN,PTF,DGADM
DO CA^DGPTTS
+3 IF DGMVT=3
DO LE^DGPTTS
GOTO Q1
+4 IF '$DATA(^UTILITY("DGPM",$JOB,6))
GOTO Q1
+5 SET DGMV=$ORDER(^UTILITY("DGPM",$JOB,6,0))
SET DGMVP=^(DGMV,"P")
SET DGMVA=^("A")
+6 IF DGMVT=1
IF DGPMP=""
SET DGNEW=""
+7 IF DGMVT=2
IF DGPMP=""
IF "^13^44^"[("^"_$PIECE(DGPMA,"^",18)_"^")
SET DGNEW=""
+8 if '$DATA(^DGPT(+PTF,0))
GOTO Q1
+9 IF DGMVP=""
IF (9999999.999999-DGMVA)'=$EXTRACT($ORDER(^DGPM("ATS",DFN,DGPMCA,0)),1,14)
DO NTR^DGPTTS
DO LE^DGPTTS
GOTO Q1
+10 IF DGMVA=""
IF DGMVT'=1
DO DEL^DGPTTS
DO LE^DGPTTS
GOTO Q1
+11 IF ^UTILITY("DGPM",$JOB,6,DGMV,"DXP")'=^("DXA")
SET DGMVDA=DGPMDA
SET DGPMDA=DGMV
if $DATA(DGNEW)
SET DGMSG1="New Admission"
DO MOV^DGPTMSG1
SET DGPMDA=DGMVDA
+12 DO LE^DGPTTS
Q1 KILL DGMVDA,DGMV,DGMVP,DGMVA,DGMVT,X,V,DGNEW,AGE,DGLAST,DGNEXT,DGY,DOB,DQ,DRG,SEX
+1 QUIT
+2 ;
