DGJTEVT ;ALB/MIR - EVENT DRIVER CALL FOR IRT ; 04 JAN 91
;;5.3;Registration;**61,1015**;Aug 13, 1993;Build 21
;
EN2 N CA,DGPMA,DGPMP,DGPMT
S DGONE=1 ;first time
F DGJII=1,2,3,6 F DGJJ=0:0 S DGJJ=$O(^UTILITY("DGPM",$J,DGJII,DGJJ)) Q:'DGJJ S DGPMA=^(DGJJ,"A"),DGPMP=^("P") D START
D DISQ K DGJTDA,DGJII,DGJJ,DGONE Q
Q
;
START ;start processing mvmts. in event driver
S CA=+$S($P(DGPMP,"^",14):$P(DGPMP,"^",14),1:$P(DGPMA,"^",14))
S DGPMT=+$S($P(DGPMP,"^",2):$P(DGPMP,"^",2),1:$P(DGPMA,"^",2))
I DGPMT=1&('DGPMA) D Q
.I DGONE,'$G(DGQUIET) W !!,"Updating incomplete records..."
.S:DGONE DGONE=0
.D DIK
D WARD^DGJTUTL
I +X S DGJTWARD=+X,X=$S($D(^DIC(42,+X,0)):$P(^(0),"^",11),1:""),DGJTDIV=X
I $S('$D(^DG(40.8,+X,"DT")):1,$D(^DG(40.8,+X,"DT"))&(+^("DT")=0):1,1:0) Q ;IRT off
EN1 I DGONE,'$G(DGQUIET) W !!,"Updating incomplete records..." S DGONE=0
I $D(^UTILITY("DGPM",$J,6)) S DGJTSIFN=$O(^(6,0))
D DIS Q
;
;if delete adm., del all corresponding summaries
;
DIK S DIK="^VAS(393," F DA=0:0 S DA=$O(^VAS(393,"ADM",DGPMDA,DA)) Q:'DA D ^DIK
K DIK,DA,DGJDIK Q
DIS ;create IRT summ., update if edit in ADT, del record if adm. deleted
N DR
S DGJTADM=$S(DGPMP:$P(DGPMP,"^",14),DGPMA:$P(DGPMA,"^",14),1:"") I 'DGJTADM G DISQ ;get adm ptr
F I=0:0 S I=$O(^VAS(393,"ADM",DGJTADM,I)) Q:'I I $D(^VAS(393,I,0)),$P(^(0),"^",2)=1 Q
I $D(I),I]"" S DGJTDA=I
I DGPMT=2,I,(DGPMA'=DGPMP),'$D(^UTILITY("DGPM",$J,6)) D CHNG Q
I DGPMT=1!(DGPMT=3) I DGPMA,'I D NEW Q:DGPMT=3 D CK S DIE="^VAS(393,",DA=DGJTDA D ^DIE Q ;no IRT rec
I DGPMT=1,DGPMP,'DGPMA,I S DIK="^VAS(393,",DA=I D ^DIK Q ;del IRT record
I DGPMT=1,I,(DGPMA'=DGPMP) S DGJTCA=I D CK,CHNG Q
I DGPMT=3,I,(DGPMA'=DGPMP) S DGJTPMA=$S(+DGPMA:+DGPMA,1:$P(^DGPM(DGJTADM,0),"^",1)) S DGJTCA=1 S DR=".03////"_DGJTPMA D CHNG Q
I DGPMT=3,'DGPMA,DGPMP S X=$P(DGPMP,"^",14) I $D(^DGPM(X,0)) S DGPMA=^DGPM(X,0) D NEW Q
I DGPMT=3 Q
I I,DGPMT=1 S DGJTCA=I
I I,^UTILITY("DGPM",$J,6,DGJTSIFN,"P")'=^UTILITY("DGPM",$J,6,DGJTSIFN,"A") D CHNG Q ;TS change
I I,^UTILITY("DGPM",$J,6,DGJTSIFN,"P")=^UTILITY("DGPM",$J,6,DGJTSIFN,"A"),$P(DGPMA,"^",6)'=$P(DGPMP,"^",6) D CHNG Q ;WARD CHNG
DISQ K DA,DIC,DIE,DIK,DR,I,DGJTADM,DGJTWD,DGJTWARD,DGJTTM,DLAYGO,DGJTST,D0,D1,DGJT,DGJT9,DGJT10,DGJTDIV,DGJTP,DGJTSIFN,DGJTSV,DIV,DGJI,DGJX,DGJTCA,DGJTPMA,DGJY,X,Y Q
;
;
NEW ;new discharge
S DGJT=$S(DGPMA]"":+$P(DGPMA,"^",14),1:+$P(DGPMP,"^",14)),DGJT=$O(^DGPM("ATS",DFN,DGJT,0)),DGJT=$O(^(+DGJT,0)),DGJT=$O(^(+DGJT,0)),DGJT=$S($D(^DGPM(+DGJT,0)):^(0),1:"") ;last TS mvt
S DGJTP=$S($D(^DG(40.8,+DGJTDIV,"DT")):^("DT"),1:"")
S DGJTWD=$S($D(^DIC(42,DGJTWARD,0)):^DIC(42,DGJTWARD,44),1:"")
S DGJTSV=$S(DGJTWARD]"":$P(^DIC(42,+DGJTWARD,0),"^",3),1:"")
S:DGJTSV']"" DGJTSV=0 S DGJTSV=$S($D(^DG(393.1,"AC",DGJTSV)):$O(^(DGJTSV,0)),1:"") I DGJTSV']"" S DGJTSV=$O(^DG(393.1,"AC",0,0))
S DGJX=8,DGJY=2 D DOC S DGJT9=X,X=""
S DGJT10="" I $P(DGJTP,"^",3)!('$P(DGJTP,"^",3)&($P(DGJTP,"^",10)="A")) S DGJX=19,DGJY=4 D DOC S DGJT10=X
I "^6^2^"[DGPMT Q
I $D(DGJTCA) Q
S X=DFN,DIC="^VAS(393,",DIC(0)="L",DLAYGO=393 K DD,DO D FILE^DICN
S DGJTST=$O(^DG(393.2,"B","INCOMPLETE",0))
I Y>0 S DIE=DIC,(DA,DGJTDA)=+Y
I Y>0 S DR=".02////1;.03////"_+DGPMA_";.04////"_+$P(DGPMA,"^",14)_";.05////"_DGJTWD_";.06////"_DGJTDIV_";.07////"_$S(+$P(DGJT,"^",9):+$P(DGJT,"^",9),1:"")_";.08////"_DGJTSV_";.09////"_DGJT9_";.1////"_DGJT10_";.11////"_DGJTST_";.12////"_DGJT9
I Y>0 D ^DIE
D DISQ Q
FILE I DGPMT=1!(DGPMT=2)!(DGPMT=3) S DR=$S($D(DR):DR_";",1:"")_".05////"_DGJTWD_";"_".06////"_DGJTDIV
S DR=$S($D(DR):DR_";",1:"")_".07////"_$S(+$P(DGJT,"^",9):+$P(DGJT,"^",9),1:"")_";.08////"_DGJTSV_";.09////"_DGJT9_";.1////"_$S(DGJT10]"":DGJT10,1:"@") D ^DIE
D DISQ
Q
;
DOC ;provider resp.
S X=$P(DGJTP,"^",DGJY)
S X=$S(X="A":$P(DGJT,"^",19),X="N":"",1:$P(DGJT,"^",8))
Q
CHNG S DGJI=I D NEW S DIE="^VAS(393,",DA=DGJI D FILE Q
;
;
CK Q:'$D(^DGPM(DGJJ,0)) I $P(^DGPM(DGJJ,0),"^",17)']"" S DGJTTM=+DGPMA
I $P(^DGPM(DGJJ,0),"^",17)]"" S X=$P(^(0),"^",17) I $D(^DGPM(X,0)) S DGJTTM=+^(0)
S DR=".03////"_DGJTTM Q
DGJTEVT ;ALB/MIR - EVENT DRIVER CALL FOR IRT ; 04 JAN 91
+1 ;;5.3;Registration;**61,1015**;Aug 13, 1993;Build 21
+2 ;
EN2 NEW CA,DGPMA,DGPMP,DGPMT
+1 ;first time
SET DGONE=1
+2 FOR DGJII=1,2,3,6
FOR DGJJ=0:0
SET DGJJ=$ORDER(^UTILITY("DGPM",$JOB,DGJII,DGJJ))
IF 'DGJJ
QUIT
SET DGPMA=^(DGJJ,"A")
SET DGPMP=^("P")
DO START
+3 DO DISQ
KILL DGJTDA,DGJII,DGJJ,DGONE
QUIT
+4 QUIT
+5 ;
START ;start processing mvmts. in event driver
+1 SET CA=+$SELECT($PIECE(DGPMP,"^",14):$PIECE(DGPMP,"^",14),1:$PIECE(DGPMA,"^",14))
+2 SET DGPMT=+$SELECT($PIECE(DGPMP,"^",2):$PIECE(DGPMP,"^",2),1:$PIECE(DGPMA,"^",2))
+3 IF DGPMT=1&('DGPMA)
Begin DoDot:1
+4 IF DGONE
IF '$GET(DGQUIET)
WRITE !!,"Updating incomplete records..."
+5 IF DGONE
SET DGONE=0
+6 DO DIK
End DoDot:1
QUIT
+7 DO WARD^DGJTUTL
+8 IF +X
SET DGJTWARD=+X
SET X=$SELECT($DATA(^DIC(42,+X,0)):$PIECE(^(0),"^",11),1:"")
SET DGJTDIV=X
+9 ;IRT off
IF $SELECT('$DATA(^DG(40.8,+X,"DT")):1,$DATA(^DG(40.8,+X,"DT"))&(+^("DT")=0):1,1:0)
QUIT
EN1 IF DGONE
IF '$GET(DGQUIET)
WRITE !!,"Updating incomplete records..."
SET DGONE=0
+1 IF $DATA(^UTILITY("DGPM",$JOB,6))
SET DGJTSIFN=$ORDER(^(6,0))
+2 DO DIS
QUIT
+3 ;
+4 ;if delete adm., del all corresponding summaries
+5 ;
DIK SET DIK="^VAS(393,"
FOR DA=0:0
SET DA=$ORDER(^VAS(393,"ADM",DGPMDA,DA))
IF 'DA
QUIT
DO ^DIK
+1 KILL DIK,DA,DGJDIK
QUIT
DIS ;create IRT summ., update if edit in ADT, del record if adm. deleted
+1 NEW DR
+2 ;get adm ptr
SET DGJTADM=$SELECT(DGPMP:$PIECE(DGPMP,"^",14),DGPMA:$PIECE(DGPMA,"^",14),1:"")
IF 'DGJTADM
GOTO DISQ
+3 FOR I=0:0
SET I=$ORDER(^VAS(393,"ADM",DGJTADM,I))
IF 'I
QUIT
IF $DATA(^VAS(393,I,0))
IF $PIECE(^(0),"^",2)=1
QUIT
+4 IF $DATA(I)
IF I]""
SET DGJTDA=I
+5 IF DGPMT=2
IF I
IF (DGPMA'=DGPMP)
IF '$DATA(^UTILITY("DGPM",$JOB,6))
DO CHNG
QUIT
+6 ;no IRT rec
IF DGPMT=1!(DGPMT=3)
IF DGPMA
IF 'I
DO NEW
IF DGPMT=3
QUIT
DO CK
SET DIE="^VAS(393,"
SET DA=DGJTDA
DO ^DIE
QUIT
+7 ;del IRT record
IF DGPMT=1
IF DGPMP
IF 'DGPMA
IF I
SET DIK="^VAS(393,"
SET DA=I
DO ^DIK
QUIT
+8 IF DGPMT=1
IF I
IF (DGPMA'=DGPMP)
SET DGJTCA=I
DO CK
DO CHNG
QUIT
+9 IF DGPMT=3
IF I
IF (DGPMA'=DGPMP)
SET DGJTPMA=$SELECT(+DGPMA:+DGPMA,1:$PIECE(^DGPM(DGJTADM,0),"^",1))
SET DGJTCA=1
SET DR=".03////"_DGJTPMA
DO CHNG
QUIT
+10 IF DGPMT=3
IF 'DGPMA
IF DGPMP
SET X=$PIECE(DGPMP,"^",14)
IF $DATA(^DGPM(X,0))
SET DGPMA=^DGPM(X,0)
DO NEW
QUIT
+11 IF DGPMT=3
QUIT
+12 IF I
IF DGPMT=1
SET DGJTCA=I
+13 ;TS change
IF I
IF ^UTILITY("DGPM",$JOB,6,DGJTSIFN,"P")'=^UTILITY("DGPM",$JOB,6,DGJTSIFN,"A")
DO CHNG
QUIT
+14 ;WARD CHNG
IF I
IF ^UTILITY("DGPM",$JOB,6,DGJTSIFN,"P")=^UTILITY("DGPM",$JOB,6,DGJTSIFN,"A")
IF $PIECE(DGPMA,"^",6)'=$PIECE(DGPMP,"^",6)
DO CHNG
QUIT
DISQ KILL DA,DIC,DIE,DIK,DR,I,DGJTADM,DGJTWD,DGJTWARD,DGJTTM,DLAYGO,DGJTST,D0,D1,DGJT,DGJT9,DGJT10,DGJTDIV,DGJTP,DGJTSIFN,DGJTSV,DIV,DGJI,DGJX,DGJTCA,DGJTPMA,DGJY,X,Y
QUIT
+1 ;
+2 ;
NEW ;new discharge
+1 ;last TS mvt
SET DGJT=$SELECT(DGPMA]"":+$PIECE(DGPMA,"^",14),1:+$PIECE(DGPMP,"^",14))
SET DGJT=$ORDER(^DGPM("ATS",DFN,DGJT,0))
SET DGJT=$ORDER(^(+DGJT,0))
SET DGJT=$ORDER(^(+DGJT,0))
SET DGJT=$SELECT($DATA(^DGPM(+DGJT,0)):^(0),1:"")
+2 SET DGJTP=$SELECT($DATA(^DG(40.8,+DGJTDIV,"DT")):^("DT"),1:"")
+3 SET DGJTWD=$SELECT($DATA(^DIC(42,DGJTWARD,0)):^DIC(42,DGJTWARD,44),1:"")
+4 SET DGJTSV=$SELECT(DGJTWARD]"":$PIECE(^DIC(42,+DGJTWARD,0),"^",3),1:"")
+5 IF DGJTSV']""
SET DGJTSV=0
SET DGJTSV=$SELECT($DATA(^DG(393.1,"AC",DGJTSV)):$ORDER(^(DGJTSV,0)),1:"")
IF DGJTSV']""
SET DGJTSV=$ORDER(^DG(393.1,"AC",0,0))
+6 SET DGJX=8
SET DGJY=2
DO DOC
SET DGJT9=X
SET X=""
+7 SET DGJT10=""
IF $PIECE(DGJTP,"^",3)!('$PIECE(DGJTP,"^",3)&($PIECE(DGJTP,"^",10)="A"))
SET DGJX=19
SET DGJY=4
DO DOC
SET DGJT10=X
+8 IF "^6^2^"[DGPMT
QUIT
+9 IF $DATA(DGJTCA)
QUIT
+10 SET X=DFN
SET DIC="^VAS(393,"
SET DIC(0)="L"
SET DLAYGO=393
KILL DD,DO
DO FILE^DICN
+11 SET DGJTST=$ORDER(^DG(393.2,"B","INCOMPLETE",0))
+12 IF Y>0
SET DIE=DIC
SET (DA,DGJTDA)=+Y
+13 IF Y>0
SET DR=".02////1;.03////"_+DGPMA_";.04////"_+$PIECE(DGPMA,"^",14)_";.05////"_DGJTWD_";.06////"_DGJTDIV_";.07////"_$SELECT(+$PIECE(DGJT,"^",9):+...
... $PIECE(DGJT,"^",9),1:"")_";.08////"_DGJTSV_";.09////"_DGJT9_";.1////"_DGJT10_";.11////"_DGJTST_";.12////"_DGJT9
+14 IF Y>0
DO ^DIE
+15 DO DISQ
QUIT
FILE IF DGPMT=1!(DGPMT=2)!(DGPMT=3)
SET DR=$SELECT($DATA(DR):DR_";",1:"")_".05////"_DGJTWD_";"_".06////"_DGJTDIV
+1 SET DR=$SELECT($DATA(DR):DR_";",1:"")_".07////"_$SELECT(+$PIECE(DGJT,"^",9):+$PIECE(DGJT,"^",9),1:"")_";.08////"_DGJTSV_";.09////"_DGJT9_";.1////"_$SELECT(DGJT10]"":DGJT10,1:"@")
DO ^DIE
+2 DO DISQ
+3 QUIT
+4 ;
DOC ;provider resp.
+1 SET X=$PIECE(DGJTP,"^",DGJY)
+2 SET X=$SELECT(X="A":$PIECE(DGJT,"^",19),X="N":"",1:$PIECE(DGJT,"^",8))
+3 QUIT
CHNG SET DGJI=I
DO NEW
SET DIE="^VAS(393,"
SET DA=DGJI
DO FILE
QUIT
+1 ;
+2 ;
CK IF '$DATA(^DGPM(DGJJ,0))
QUIT
IF $PIECE(^DGPM(DGJJ,0),"^",17)']""
SET DGJTTM=+DGPMA
+1 IF $PIECE(^DGPM(DGJJ,0),"^",17)]""
SET X=$PIECE(^(0),"^",17)
IF $DATA(^DGPM(X,0))
SET DGJTTM=+^(0)
+2 SET DR=".03////"_DGJTTM
QUIT
