DGPMEVT ;ALB/RMO - MAS MOVEMENT EVENT DRIVER; 26 DEC 89 ; 2/2/04 3:18pm
;;5.3;Registration;**61,574,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 3/08/2001 using IHS protocol menu for event driver
; 5/02/2001 added setting of IHS variables
;
;Required Variables:
; DFN = Patient's IFN
; DGPMDA = Movement's IFN
; DGPMP = 0 Node of Primary Movement PRIOR to Add/Edit/Delete
; DGPMA = 0 Node of Primary Movement AFTER Add/Edit/Delete
; DGQUIET = If $G(DGQUIET) then the read/writes should not
; occur (optional)
;
K DTOUT,DIROUT
; **************************************************************
;-- establish visit & set pt movement ptr
I $P($G(^DIC(150.9,1,0)),U,2)["1" D VISIT
; **************************************************************
;IHS/ANMC/LJF 5/2/01 set up IHS variables if not already sent
I $G(DGPMP)="",$G(DGPMA)="" Q ;nothing added
S DGPMCA=$$GET1^DIQ(405,DGPMDA,.14,"I") ;admission ien
I DGPMCA="" S DGPMCA=$P(DGPMP,U,14) ;in case movement deleted
;IHS/ANMC/LJF 5/2/01 end of new code
;
;
;N OROLD D INP^VADPT S X=$O(^ORD(101,"B","DGPM MOVEMENT EVENTS",0))_";ORD(101," D EN1^XQOR:X K VAIN,X ;IHS/ANMC/LJF 3/08/2001
N OROLD D INP^VADPT S X=$O(^ORD(101,"B","BDGPM MOVEMENT EVENTS",0))_";ORD(101," D EN1^XQOR:X K VAIN,X ;IHS/ANMC/LJF 3/08/2001
Q
;N OROLD D INP^VADPT S X=$O(^ORD(101,"B","DGPM MOVEMENT EVENTS",0))_";ORD(101,"
;I $P(X,";",1)="" D ERR K VAIN Q
;D EN1^XQOR K VAIN,X
Q
;
ERR ;
W !,"Serious error ! DGPM MOVEMENT EVENTS protocol not found"
W !,"in Protocol file #101. No events fired !"
W !
Q
;
VISIT ;-- create visit file entry for new admissions
;
;-- Loop through ^UTILITY for admissions, if no prior movement
; then new admission. This will capture admissions for ASIH.
N DGX,DGY
S DGX=""
F S DGX=$O(^UTILITY("DGPM",$J,1,DGX)) Q:'DGX D
. I $G(^UTILITY("DGPM",$J,1,DGX,"A"))]"",$G(^("P"))="" S DGY=^("A") D
.. S DGY=$$NEW(DGX,DGY)
.. S ^UTILITY("DGPM",$J,1,DGX,"A")=DGY
.. S:DGPMDA=DGX DGPMA=DGY
K VSIT
Q
;
NEW(DGPM,DGPMA) ; --- add a new entry, new admit
; INPUT : DGPM - IEN of admission movement
; DGPMA - Oth node of admission movement
K VSIT
;
;-- define admission
;
;--location
I $D(^DIC(42,+$P(DGPMA,"^",6),44)) S VSIT("LOC")=+^(44)
I $D(VSIT("LOC")),'$D(^SC(+VSIT("LOC"),0)) K VSIT("LOC")
;
;--eligibility
S VSIT("ELG")=$S(+$P(DGPMA,U,20):+$P(DGPMA,U,20),1:+$G(^DPT($P(DGPMA,U,3),.36)))
G:'VSIT("ELG") NEWQ
;
;-- get vt ien
S VSIT=+DGPMA,VSIT(0)="F",VSIT("SVC")="H"
D ^VSIT
;
;-- add the vt entry to the admission
I +$G(VSIT("IEN")) D
. S DIE="^DGPM(",DA=+DGPM,DR=".27////"_+VSIT("IEN") D ^DIE
. K DIC,DIE,DA,DR
. S $P(DGPMA,"^",27)=+VSIT("IEN")
;
NEWQ ;
K VSIT
Q DGPMA
;
DGPMEVT ;ALB/RMO - MAS MOVEMENT EVENT DRIVER; 26 DEC 89 ; 2/2/04 3:18pm
+1 ;;5.3;Registration;**61,574,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 3/08/2001 using IHS protocol menu for event driver
+3 ; 5/02/2001 added setting of IHS variables
+4 ;
+5 ;Required Variables:
+6 ; DFN = Patient's IFN
+7 ; DGPMDA = Movement's IFN
+8 ; DGPMP = 0 Node of Primary Movement PRIOR to Add/Edit/Delete
+9 ; DGPMA = 0 Node of Primary Movement AFTER Add/Edit/Delete
+10 ; DGQUIET = If $G(DGQUIET) then the read/writes should not
+11 ; occur (optional)
+12 ;
+13 KILL DTOUT,DIROUT
+14 ; **************************************************************
+15 ;-- establish visit & set pt movement ptr
+16 IF $PIECE($GET(^DIC(150.9,1,0)),U,2)["1"
DO VISIT
+17 ; **************************************************************
+18 ;IHS/ANMC/LJF 5/2/01 set up IHS variables if not already sent
+19 ;nothing added
IF $GET(DGPMP)=""
IF $GET(DGPMA)=""
QUIT
+20 ;admission ien
SET DGPMCA=$$GET1^DIQ(405,DGPMDA,.14,"I")
+21 ;in case movement deleted
IF DGPMCA=""
SET DGPMCA=$PIECE(DGPMP,U,14)
+22 ;IHS/ANMC/LJF 5/2/01 end of new code
+23 ;
+24 ;
+25 ;N OROLD D INP^VADPT S X=$O(^ORD(101,"B","DGPM MOVEMENT EVENTS",0))_";ORD(101," D EN1^XQOR:X K VAIN,X ;IHS/ANMC/LJF 3/08/2001
+26 ;IHS/ANMC/LJF 3/08/2001
NEW OROLD
DO INP^VADPT
SET X=$ORDER(^ORD(101,"B","BDGPM MOVEMENT EVENTS",0))_";ORD(101,"
IF X
DO EN1^XQOR
KILL VAIN,X
+27 QUIT
+28 ;N OROLD D INP^VADPT S X=$O(^ORD(101,"B","DGPM MOVEMENT EVENTS",0))_";ORD(101,"
+29 ;I $P(X,";",1)="" D ERR K VAIN Q
+30 ;D EN1^XQOR K VAIN,X
+31 QUIT
+32 ;
ERR ;
+1 WRITE !,"Serious error ! DGPM MOVEMENT EVENTS protocol not found"
+2 WRITE !,"in Protocol file #101. No events fired !"
+3 WRITE !
+4 QUIT
+5 ;
VISIT ;-- create visit file entry for new admissions
+1 ;
+2 ;-- Loop through ^UTILITY for admissions, if no prior movement
+3 ; then new admission. This will capture admissions for ASIH.
+4 NEW DGX,DGY
+5 SET DGX=""
+6 FOR
SET DGX=$ORDER(^UTILITY("DGPM",$JOB,1,DGX))
IF 'DGX
QUIT
Begin DoDot:1
+7 IF $GET(^UTILITY("DGPM",$JOB,1,DGX,"A"))]""
IF $GET(^("P"))=""
SET DGY=^("A")
Begin DoDot:2
+8 SET DGY=$$NEW(DGX,DGY)
+9 SET ^UTILITY("DGPM",$JOB,1,DGX,"A")=DGY
+10 IF DGPMDA=DGX
SET DGPMA=DGY
End DoDot:2
End DoDot:1
+11 KILL VSIT
+12 QUIT
+13 ;
NEW(DGPM,DGPMA) ; --- add a new entry, new admit
+1 ; INPUT : DGPM - IEN of admission movement
+2 ; DGPMA - Oth node of admission movement
+3 KILL VSIT
+4 ;
+5 ;-- define admission
+6 ;
+7 ;--location
+8 IF $DATA(^DIC(42,+$PIECE(DGPMA,"^",6),44))
SET VSIT("LOC")=+^(44)
+9 IF $DATA(VSIT("LOC"))
IF '$DATA(^SC(+VSIT("LOC"),0))
KILL VSIT("LOC")
+10 ;
+11 ;--eligibility
+12 SET VSIT("ELG")=$SELECT(+$PIECE(DGPMA,U,20):+$PIECE(DGPMA,U,20),1:+$GET(^DPT($PIECE(DGPMA,U,3),.36)))
+13 IF 'VSIT("ELG")
GOTO NEWQ
+14 ;
+15 ;-- get vt ien
+16 SET VSIT=+DGPMA
SET VSIT(0)="F"
SET VSIT("SVC")="H"
+17 DO ^VSIT
+18 ;
+19 ;-- add the vt entry to the admission
+20 IF +$GET(VSIT("IEN"))
Begin DoDot:1
+21 SET DIE="^DGPM("
SET DA=+DGPM
SET DR=".27////"_+VSIT("IEN")
DO ^DIE
+22 KILL DIC,DIE,DA,DR
+23 SET $PIECE(DGPMA,"^",27)=+VSIT("IEN")
End DoDot:1
+24 ;
NEWQ ;
+1 KILL VSIT
+2 QUIT DGPMA
+3 ;
