- DGJTEVT ;ALB/MIR - EVENT DRIVER CALL FOR IRT ; 04 JAN 91
- ;;1.0;Incomplete Records Tracking;;Jun 25, 2001
- ;
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGJTEVT 4105 printed Mar 13, 2025@21:05:39 Page 2
- DGJTEVT ;ALB/MIR - EVENT DRIVER CALL FOR IRT ; 04 JAN 91
- +1 ;;1.0;Incomplete Records Tracking;;Jun 25, 2001
- +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
