DGRUUTL1 ;ALB/GRR - RAI/MDS UTILITY ROUTINE
;;5.3;Registration;**190,312,328,373,434,430,464**;Aug 13, 1993
EN ;Process each division for routing
N DGRDIV,DGDIV ;New all variables used
K HLL ;Kill HLL which is used for an array
S DGDIV=$$ENGET^DGRUGMFU()
D ENMFU^DGRUDYN("MFU",DGDIV) ;Do API which gets subscriber(s) for the division
Q
;
LOCTRAN(DGPV1) ;TRANSLATE WARD AND ROOM-BED
N DGCW,DGPW,DGPR,DGPB,DGW,DGR,DGB,DGPL,DGLOC,DGI,DGCRB,DGPRB ;modified p-373
S DGLOC=$P(DGPV1,HL("FS"),4),DGPLOC=$P(DGPV1,HL("FS"),7)
S DGW=$P(DGLOC,$E(HL("ECH"))),DGR=$P(DGLOC,$E(HL("ECH")),2),DGB=$P(DGLOC,$E(HL("ECH")),3)
S DGPWN=$P(DGPLOC,$E(HL("ECH"))),DGPR=$P(DGPLOC,$E(HL("ECH")),2),DGPB=$P(DGPLOC,$E(HL("ECH")),3)
N DGETYPE S DGETYPE=$P($G(@DGARRAY@(1)),HL("FS"),2) G:DGETYPE="" LOCEX
;
I DGETYPE="A01" D
.S DGCW=$P($G(DGPMA),"^",6),(DGPW,DGPWN,DGPR,DGPB)=""
.S DGCRB=$P($G(DGPMA),"^",7),DGPRB=""
;
I DGETYPE="A02" D
.S DGCW=$P($G(DGPMA),"^",6),DGPW=$P($G(DGPMVI(5)),"^")
.S DGCRB=$P($G(DGPMA),"^",7),DGPRB=$P($G(DGPMVI(6)),"^")
.I $G(DGBS)=1 D ;p-464 BED SWITCH
..S DGPWN=DGW,DGPW=DGCW,DGPRBN=$P($G(DGPMVI(6)),"^",2) ;p-464
..S DGPR=$P(DGPRBN,"-",1),DGPB=$P(DGPRBN,"-",2) ;p-464
.I DGPW=""!(DGPRB="") S DGPW=DGCW,DGPRB=DGCRB
;
I DGETYPE="A03" D
.I $G(DGXFR0)]"" D
..S (DGCW,DGPW)=$P(DGXFR0,"^",6)
..S (DGCRB,DGPRB)=$P(DGXFR0,"^",7)
.I $G(DGPMAN)]"" D
..S (DGCW,DGPW)=$P(DGPMAN,"^",6)
..S (DGCRB,DGPRB)=$P(DGPMAN,"^",7)
.I $G(DGPMVI(5))]"" D
..S (DGCW,DGPW)=$P($G(DGPMVI(5)),"^")
..S (DGCRB,DGPRB)=$P($G(DGPMVI(6)),"^")
.I $G(DGMOVE)=47 D ;p-430
..S (DGCW,DGPW)=$P($G(DGRU(17,4)),"^") ;p-430
..S (DGCRB,DGPRB)=$P($G(DGRU(17,4)),"^",2) ;p-430
;
I DGETYPE="A08" D
.N VAIP D IN5^VADPT
.S DGCW=+$G(VAIP(5)),DGPW=+$G(VAIP(15,4))
.S DGCRB=+$G(VAIP(6)),DGPRB=""
.N DGMIEN S DGMIEN=+$G(VAIP(15)) I DGMIEN>0 S DGPRB=$$GET1^DIQ(405,DGMIEN,.07,"I") K DGMIEN
;
I DGETYPE="A11" D
.S (DGCW,DGPW)=$P($G(DGPMVI(5)),"^")
.S (DGCRB,DGPRB)=$P($G(DGPMVI(6)),"^")
;
I DGETYPE="A12" D
.S (DGCW,DGPW)=$P($G(DGPM0),"^",6),DGPWN=DGW
.S (DGCRB,DGPRB)=$P($G(DGPM0),"^",7),DGPR=DGR,DGPB=DGB
;
I DGETYPE="A13" D
.S (DGCW,DGPW)=$P($G(DGPM0),"^",6),DGPWN=DGW
.S (DGCRB,DGPRB)=$P($G(DGPM0),"^",7),DGPR=DGR,DGPB=DGB
;
I DGETYPE="A21" D ;modified p-373
.I $G(DGPMVI(5))]"" D Q
..S (DGCW,DGPW)=$P($G(DGPMVI(5)),"^")
..S (DGCRB,DGPRB)=$P($G(DGPMVI(6)),"^")
.I $G(DGPMA)]"" D ;p-434
..S (DGCW,DGPW)=$P(DGPMA,"^",6) ;p-434
..S (DGCRB,DGPRB)=$P(DGPMA,"^",7) ;p-434
.I $G(DGPMAN)]"" D
..S DGCW=$P($G(DGPMA),"^",6),DGPW=$P($G(DGPMAN),"^",6)
..S DGCRB=$P($G(DGPMA),"^",7),DGPRB=$P($G(DGPMAN),"^",7)
I DGETYPE="A22" D ;added p-373
.I $G(TRSNODE)]"" D Q ;added p-373
..S DGCW=$P($G(TRSNODE),"^",6),DGPW=$P($G(TRSNODE),"^",6) ;added p-373
..S DGCRB=$P($G(TRSNODE),"^",7),DGPRB=$P($G(TRSNODE),"^",7) ;added p-373
.I $P($G(DGPMVI(5)),"^")]""&($P($G(DGPMVI(6)),"^")]"") D Q ;added p-373,p-430
..S (DGCW,DGPW)=$P($G(DGPMVI(5)),"^") ;added p-373
..S (DGCRB,DGPRB)=$P($G(DGPMVI(6)),"^") ;added p-373
.I $D(VAFH(2,DGMIEN,"A")) D ;added p-373
..S (DGCW,DGPW)=$P(VAFH(2,DGMIEN,"A"),"^",6) ;added p-373
..S (DGCRB,DGPRB)=$P(VAFH(2,DGMIEN,"A"),"^",7) ;added p-373
SKIP1 ;
S DGNW=$$WARDTRAN(DGCW,DGW)
S DGNRB=$$RBTRAN(DGCRB,DGR_"-"_DGB)
S DGNPW=$$WARDTRAN(DGPW,DGPWN)
S DGNPRB=$$RBTRAN(DGPRB,DGPR_"-"_DGPB)
S DGNLOC=$S(DGLOC="":"",1:DGNW_$E(HL("ECH"))_$P(DGNRB,"-")_$E(HL("ECH"))_$P(DGNRB,"-",2)),DGNPLOC=$S(DGNPW="":"",1:DGNPW_$E(HL("ECH"))_$P(DGNPRB,"-")_$E(HL("ECH"))_$P(DGNPRB,"-",2))
S $P(DGPV1,HL("FS"),4)=DGNLOC,$P(DGPV1,HL("FS"),7)=DGNPLOC
LOCEX Q DGPV1
;
WARDTRAN(DGWIEN,DGWNAM) ;
I DGWNAM=""!(DGWNAM=HLQ)!(DGWIEN="") Q DGWNAM
S DGCI=$O(^DGRU(46.12,"B",DGWIEN,0)) I DGCI="" Q DGWNAM
S DGTNW=$$GET1^DIQ(46.12,DGCI,.02,"I")
Q DGTNW
RBTRAN(DGRBIEN,DGRBNAM) ;
I DGRBNAM=""!(DGRBNAM[HLQ)!(DGRBIEN="") Q DGRBNAM
S DGCI=$O(^DGRU(46.13,"B",DGRBIEN,0)) I DGCI="" Q DGRBNAM
S DGRB=$$GET1^DIQ(46.13,DGCI,.02,"I")
Q DGRB
;
DOCTOR(X) ;DETERMINE IF NEW PERSON A PHYSICIAN ;added 1/12/2000
Q 0 ;always flag as non-physician, no need to send these anymore
S DGPCN=$$GET1^DIQ(7,X,.01,"I")
Q DGPCN["PHYSICIAN"
;
IN1(DFN) ;CREATE IN1 SEGMENT
N DGADT,DGREC,VAIP
D IN5^VADPT
S DGADT=$S(VAIP(13,1)]"":+$P(VAIP(13,1),"^"),1:"") I DGADT]"" S DGADT=DGADT\1,DGADT=$$HLDATE^HLFNC(DGADT)
S DGREC="IN1"_HL("FS")_HL("FS")_HL("FS")_"VA"_HL("FS")_"VETERANS ADMINISTRATION"
S $P(DGREC,HL("FS"),13)=DGADT
Q DGREC
;
CALCDT(DFN,DGMIEN) ;CALCULATE FUTURE DISCHARGE DATE
N DGOIEN,DGOLDD,DGDT,DGHDT
S Z=$O(^DGPM("ATID2",DFN,0)),DGOIEN=$O(^DGPM("ATID2",DFN,Z,DGMIEN))
S DGOLDD=$$GET1^DIQ(405,DGOIEN,.01,"I")
S X1=DGOLDD,X2=30 D C^%DTC S DGDT=X,DGHDT=$$HLDATE^HLFNC(DGDT)
Q DGHDT
;
ENTS ;USED TO REVIEW HL7 MESSAGES FOR TROUBLE SHOOTING
N DA,X,ZZ,ZX
N DIC,Y S DIC=771,DIC(0)="MX",X="DGRU RAI EVENTS" D ^DIC S ZX=+Y
I Y<0 W !,"The 'DGRU RAI EVENTS' entry in file 771 missing!" Q
S DA=999999999999
D PRIOR(.DA)
RD2 S DIR(0)="F^1:1",DIR("A")="(U)p or (D)own" D ^DIR K DIR
I X="U" D PRIOR(.DA) G RD2
I X="D" D NEXT(.DA) G RD2
Q
;
PRIOR(DA) ;
F S DA=$O(^HL(772,DA),-1) Q:DA="" I $P($G(^HL(772,DA,0)),"^",2)=ZX D Q
.S DGHMID=$P(^HL(772,DA,0),"^",8),DGMESS=$O(^HLMA("B",DGHMID,0)) Q:DGMESS=""
.W !,"Message ID: ",$P($G(^HLMA(+DGMESS,0)),"^",2)
.S ZZ=0 F S ZZ=$O(^HL(772,DA,"IN",ZZ)) Q:ZZ'>0 W !,^(ZZ,0)
I DA="" W "...At the Top.." S DA=9999999999
Q
NEXT(DA) ;
F S DA=$O(^HL(772,DA)) Q:DA'>0 I $P($G(^HL(772,DA,0)),"^",2)=ZX D Q
.S DGHMID=$P(^HL(772,DA,0),"^",8),DGMESS=$O(^HLMA("B",DGHMID,0)) Q:DGMESS=""
.W !,"Message ID: ",$P($G(^HLMA(+DGMESS,0)),"^",2)
.S ZZ=0 F S ZZ=$O(^HL(772,DA,"IN",ZZ)) Q:ZZ'>0 W !,^(ZZ,0)
I DA'>0 W "...Bottomed out.." S DA=99999999999
Q
;
GETDIV(X) ;GET DIVISION FOR SPECIFIED WARD
;
;X = Ward IEN
Q:$G(X)="" -1
S X=$$GET1^DIQ(42,X,.015,"I")
Q X
;
CKADMIT(DFN) ;CHECH IF INTEGRATED SITE FOR ORIGINAL ADMIT DATE
N DGASIH,DGINTEG,DGZDT,DGNDT,DGPMDA,DGQ
S (DGZDT,DGNDT)=""
S DGQ=0
F S DGZDT=$O(^DGPM("APTT1",DFN,DGZDT),-1) Q:DGZDT="" D Q:DGQ=1
.S DGPMDA=$O(^DGPM("APTT1",DFN,DGZDT,0))
.S DGASIH=$$GET1^DIQ(405,DGPMDA,.22,"I")
.Q:DGASIH>0
.S DGNDT=$$GET1^DIQ(405,DGPMDA,300,"I"),DGQ=1
Q DGNDT
;
FLLTCM(DFN) ;
;Find last movement before patient goes ASIH
N DGLASTA,DGLASTT,DGTIEN,DGLTCA,DGLTCIEN ;p-430
S DGTIEN="" ;p-430
G:DFN="" QUIT ;p-430
;If not inpatient, was ASIH to other facility. Get transfer movement
I '$D(^DPT(DFN,.1)) S DGTIEN=$O(^DGPM("APTT2",DFN,DGTIEN),-1),DGTIEN=$O(^DGPM("APTT2",DFN,DGTIEN,0)) G QUIT
;
;Get last Admision
S DGLASTA=$O(^DGPM("APTT1",DFN,""),-1) ;p-430
;
;Quit if last admit not to ASIH (date length less than 15 characters)
G:DGLASTA=""!($L(DGLASTA)'=15) QUIT ;p-430
;
;Get LTC admit ien
S DGLTCA=$O(^DGPM("APTT1",DFN,DGLASTA),-1) ;p-430
G:DGLTCA="" QUIT ;p-430
S DGLTCIEN=$O(^DGPM("APTT1",DFN,DGLTCA,0)) ;p-430
;
;Look for last transfer before ASIH admit
S DGLASTT=$E(DGLASTA,1,14)_"1" ;p-430
S DGTIEN=$O(^DGPM("APTT2",DFN,DGLASTT),-1) ;p-430
;
;If no transfers use admit movement
I DGTIEN="" S DGTIEN=DGLTCIEN G QUIT ;p-430
S DGTIEN=$O(^DGPM("APTT2",DFN,DGTIEN,0)) ;p-430
I $P(^DGPM(DGTIEN,0),"^",14)'=DGLTCIEN S DGTIEN=DGLTCIEN G QUIT ;p-430
QUIT Q DGTIEN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRUUTL1 7405 printed Dec 13, 2024@02:58:43 Page 2
DGRUUTL1 ;ALB/GRR - RAI/MDS UTILITY ROUTINE
+1 ;;5.3;Registration;**190,312,328,373,434,430,464**;Aug 13, 1993
EN ;Process each division for routing
+1 ;New all variables used
NEW DGRDIV,DGDIV
+2 ;Kill HLL which is used for an array
KILL HLL
+3 SET DGDIV=$$ENGET^DGRUGMFU()
+4 ;Do API which gets subscriber(s) for the division
DO ENMFU^DGRUDYN("MFU",DGDIV)
+5 QUIT
+6 ;
LOCTRAN(DGPV1) ;TRANSLATE WARD AND ROOM-BED
+1 ;modified p-373
NEW DGCW,DGPW,DGPR,DGPB,DGW,DGR,DGB,DGPL,DGLOC,DGI,DGCRB,DGPRB
+2 SET DGLOC=$PIECE(DGPV1,HL("FS"),4)
SET DGPLOC=$PIECE(DGPV1,HL("FS"),7)
+3 SET DGW=$PIECE(DGLOC,$EXTRACT(HL("ECH")))
SET DGR=$PIECE(DGLOC,$EXTRACT(HL("ECH")),2)
SET DGB=$PIECE(DGLOC,$EXTRACT(HL("ECH")),3)
+4 SET DGPWN=$PIECE(DGPLOC,$EXTRACT(HL("ECH")))
SET DGPR=$PIECE(DGPLOC,$EXTRACT(HL("ECH")),2)
SET DGPB=$PIECE(DGPLOC,$EXTRACT(HL("ECH")),3)
+5 NEW DGETYPE
SET DGETYPE=$PIECE($GET(@DGARRAY@(1)),HL("FS"),2)
if DGETYPE=""
GOTO LOCEX
+6 ;
+7 IF DGETYPE="A01"
Begin DoDot:1
+8 SET DGCW=$PIECE($GET(DGPMA),"^",6)
SET (DGPW,DGPWN,DGPR,DGPB)=""
+9 SET DGCRB=$PIECE($GET(DGPMA),"^",7)
SET DGPRB=""
End DoDot:1
+10 ;
+11 IF DGETYPE="A02"
Begin DoDot:1
+12 SET DGCW=$PIECE($GET(DGPMA),"^",6)
SET DGPW=$PIECE($GET(DGPMVI(5)),"^")
+13 SET DGCRB=$PIECE($GET(DGPMA),"^",7)
SET DGPRB=$PIECE($GET(DGPMVI(6)),"^")
+14 ;p-464 BED SWITCH
IF $GET(DGBS)=1
Begin DoDot:2
+15 ;p-464
SET DGPWN=DGW
SET DGPW=DGCW
SET DGPRBN=$PIECE($GET(DGPMVI(6)),"^",2)
+16 ;p-464
SET DGPR=$PIECE(DGPRBN,"-",1)
SET DGPB=$PIECE(DGPRBN,"-",2)
End DoDot:2
+17 IF DGPW=""!(DGPRB="")
SET DGPW=DGCW
SET DGPRB=DGCRB
End DoDot:1
+18 ;
+19 IF DGETYPE="A03"
Begin DoDot:1
+20 IF $GET(DGXFR0)]""
Begin DoDot:2
+21 SET (DGCW,DGPW)=$PIECE(DGXFR0,"^",6)
+22 SET (DGCRB,DGPRB)=$PIECE(DGXFR0,"^",7)
End DoDot:2
+23 IF $GET(DGPMAN)]""
Begin DoDot:2
+24 SET (DGCW,DGPW)=$PIECE(DGPMAN,"^",6)
+25 SET (DGCRB,DGPRB)=$PIECE(DGPMAN,"^",7)
End DoDot:2
+26 IF $GET(DGPMVI(5))]""
Begin DoDot:2
+27 SET (DGCW,DGPW)=$PIECE($GET(DGPMVI(5)),"^")
+28 SET (DGCRB,DGPRB)=$PIECE($GET(DGPMVI(6)),"^")
End DoDot:2
+29 ;p-430
IF $GET(DGMOVE)=47
Begin DoDot:2
+30 ;p-430
SET (DGCW,DGPW)=$PIECE($GET(DGRU(17,4)),"^")
+31 ;p-430
SET (DGCRB,DGPRB)=$PIECE($GET(DGRU(17,4)),"^",2)
End DoDot:2
End DoDot:1
+32 ;
+33 IF DGETYPE="A08"
Begin DoDot:1
+34 NEW VAIP
DO IN5^VADPT
+35 SET DGCW=+$GET(VAIP(5))
SET DGPW=+$GET(VAIP(15,4))
+36 SET DGCRB=+$GET(VAIP(6))
SET DGPRB=""
+37 NEW DGMIEN
SET DGMIEN=+$GET(VAIP(15))
IF DGMIEN>0
SET DGPRB=$$GET1^DIQ(405,DGMIEN,.07,"I")
KILL DGMIEN
End DoDot:1
+38 ;
+39 IF DGETYPE="A11"
Begin DoDot:1
+40 SET (DGCW,DGPW)=$PIECE($GET(DGPMVI(5)),"^")
+41 SET (DGCRB,DGPRB)=$PIECE($GET(DGPMVI(6)),"^")
End DoDot:1
+42 ;
+43 IF DGETYPE="A12"
Begin DoDot:1
+44 SET (DGCW,DGPW)=$PIECE($GET(DGPM0),"^",6)
SET DGPWN=DGW
+45 SET (DGCRB,DGPRB)=$PIECE($GET(DGPM0),"^",7)
SET DGPR=DGR
SET DGPB=DGB
End DoDot:1
+46 ;
+47 IF DGETYPE="A13"
Begin DoDot:1
+48 SET (DGCW,DGPW)=$PIECE($GET(DGPM0),"^",6)
SET DGPWN=DGW
+49 SET (DGCRB,DGPRB)=$PIECE($GET(DGPM0),"^",7)
SET DGPR=DGR
SET DGPB=DGB
End DoDot:1
+50 ;
+51 ;modified p-373
IF DGETYPE="A21"
Begin DoDot:1
+52 IF $GET(DGPMVI(5))]""
Begin DoDot:2
+53 SET (DGCW,DGPW)=$PIECE($GET(DGPMVI(5)),"^")
+54 SET (DGCRB,DGPRB)=$PIECE($GET(DGPMVI(6)),"^")
End DoDot:2
QUIT
+55 ;p-434
IF $GET(DGPMA)]""
Begin DoDot:2
+56 ;p-434
SET (DGCW,DGPW)=$PIECE(DGPMA,"^",6)
+57 ;p-434
SET (DGCRB,DGPRB)=$PIECE(DGPMA,"^",7)
End DoDot:2
+58 IF $GET(DGPMAN)]""
Begin DoDot:2
+59 SET DGCW=$PIECE($GET(DGPMA),"^",6)
SET DGPW=$PIECE($GET(DGPMAN),"^",6)
+60 SET DGCRB=$PIECE($GET(DGPMA),"^",7)
SET DGPRB=$PIECE($GET(DGPMAN),"^",7)
End DoDot:2
End DoDot:1
+61 ;added p-373
IF DGETYPE="A22"
Begin DoDot:1
+62 ;added p-373
IF $GET(TRSNODE)]""
Begin DoDot:2
+63 ;added p-373
SET DGCW=$PIECE($GET(TRSNODE),"^",6)
SET DGPW=$PIECE($GET(TRSNODE),"^",6)
+64 ;added p-373
SET DGCRB=$PIECE($GET(TRSNODE),"^",7)
SET DGPRB=$PIECE($GET(TRSNODE),"^",7)
End DoDot:2
QUIT
+65 ;added p-373,p-430
IF $PIECE($GET(DGPMVI(5)),"^")]""&($PIECE($GET(DGPMVI(6)),"^")]"")
Begin DoDot:2
+66 ;added p-373
SET (DGCW,DGPW)=$PIECE($GET(DGPMVI(5)),"^")
+67 ;added p-373
SET (DGCRB,DGPRB)=$PIECE($GET(DGPMVI(6)),"^")
End DoDot:2
QUIT
+68 ;added p-373
IF $DATA(VAFH(2,DGMIEN,"A"))
Begin DoDot:2
+69 ;added p-373
SET (DGCW,DGPW)=$PIECE(VAFH(2,DGMIEN,"A"),"^",6)
+70 ;added p-373
SET (DGCRB,DGPRB)=$PIECE(VAFH(2,DGMIEN,"A"),"^",7)
End DoDot:2
End DoDot:1
SKIP1 ;
+1 SET DGNW=$$WARDTRAN(DGCW,DGW)
+2 SET DGNRB=$$RBTRAN(DGCRB,DGR_"-"_DGB)
+3 SET DGNPW=$$WARDTRAN(DGPW,DGPWN)
+4 SET DGNPRB=$$RBTRAN(DGPRB,DGPR_"-"_DGPB)
+5 SET DGNLOC=$SELECT(DGLOC="":"",1:DGNW_$EXTRACT(HL("ECH"))_$PIECE(DGNRB,"-")_$EXTRACT(HL("ECH"))_$PIECE(DGNRB,"-",2))
SET DGNPLOC=$SELECT(DGNPW="":"",1:DGNPW_$EXTRACT(HL("ECH"))_$PIECE(DGNPRB,"-")_$EXTRACT(HL("ECH"))_$PIECE(DGNPRB,"-",2))
+6 SET $PIECE(DGPV1,HL("FS"),4)=DGNLOC
SET $PIECE(DGPV1,HL("FS"),7)=DGNPLOC
LOCEX QUIT DGPV1
+1 ;
WARDTRAN(DGWIEN,DGWNAM) ;
+1 IF DGWNAM=""!(DGWNAM=HLQ)!(DGWIEN="")
QUIT DGWNAM
+2 SET DGCI=$ORDER(^DGRU(46.12,"B",DGWIEN,0))
IF DGCI=""
QUIT DGWNAM
+3 SET DGTNW=$$GET1^DIQ(46.12,DGCI,.02,"I")
+4 QUIT DGTNW
RBTRAN(DGRBIEN,DGRBNAM) ;
+1 IF DGRBNAM=""!(DGRBNAM[HLQ)!(DGRBIEN="")
QUIT DGRBNAM
+2 SET DGCI=$ORDER(^DGRU(46.13,"B",DGRBIEN,0))
IF DGCI=""
QUIT DGRBNAM
+3 SET DGRB=$$GET1^DIQ(46.13,DGCI,.02,"I")
+4 QUIT DGRB
+5 ;
DOCTOR(X) ;DETERMINE IF NEW PERSON A PHYSICIAN ;added 1/12/2000
+1 ;always flag as non-physician, no need to send these anymore
QUIT 0
+2 SET DGPCN=$$GET1^DIQ(7,X,.01,"I")
+3 QUIT DGPCN["PHYSICIAN"
+4 ;
IN1(DFN) ;CREATE IN1 SEGMENT
+1 NEW DGADT,DGREC,VAIP
+2 DO IN5^VADPT
+3 SET DGADT=$SELECT(VAIP(13,1)]"":+$PIECE(VAIP(13,1),"^"),1:"")
IF DGADT]""
SET DGADT=DGADT\1
SET DGADT=$$HLDATE^HLFNC(DGADT)
+4 SET DGREC="IN1"_HL("FS")_HL("FS")_HL("FS")_"VA"_HL("FS")_"VETERANS ADMINISTRATION"
+5 SET $PIECE(DGREC,HL("FS"),13)=DGADT
+6 QUIT DGREC
+7 ;
CALCDT(DFN,DGMIEN) ;CALCULATE FUTURE DISCHARGE DATE
+1 NEW DGOIEN,DGOLDD,DGDT,DGHDT
+2 SET Z=$ORDER(^DGPM("ATID2",DFN,0))
SET DGOIEN=$ORDER(^DGPM("ATID2",DFN,Z,DGMIEN))
+3 SET DGOLDD=$$GET1^DIQ(405,DGOIEN,.01,"I")
+4 SET X1=DGOLDD
SET X2=30
DO C^%DTC
SET DGDT=X
SET DGHDT=$$HLDATE^HLFNC(DGDT)
+5 QUIT DGHDT
+6 ;
ENTS ;USED TO REVIEW HL7 MESSAGES FOR TROUBLE SHOOTING
+1 NEW DA,X,ZZ,ZX
+2 NEW DIC,Y
SET DIC=771
SET DIC(0)="MX"
SET X="DGRU RAI EVENTS"
DO ^DIC
SET ZX=+Y
+3 IF Y<0
WRITE !,"The 'DGRU RAI EVENTS' entry in file 771 missing!"
QUIT
+4 SET DA=999999999999
+5 DO PRIOR(.DA)
RD2 SET DIR(0)="F^1:1"
SET DIR("A")="(U)p or (D)own"
DO ^DIR
KILL DIR
+1 IF X="U"
DO PRIOR(.DA)
GOTO RD2
+2 IF X="D"
DO NEXT(.DA)
GOTO RD2
+3 QUIT
+4 ;
PRIOR(DA) ;
+1 FOR
SET DA=$ORDER(^HL(772,DA),-1)
if DA=""
QUIT
IF $PIECE($GET(^HL(772,DA,0)),"^",2)=ZX
Begin DoDot:1
+2 SET DGHMID=$PIECE(^HL(772,DA,0),"^",8)
SET DGMESS=$ORDER(^HLMA("B",DGHMID,0))
if DGMESS=""
QUIT
+3 WRITE !,"Message ID: ",$PIECE($GET(^HLMA(+DGMESS,0)),"^",2)
+4 SET ZZ=0
FOR
SET ZZ=$ORDER(^HL(772,DA,"IN",ZZ))
if ZZ'>0
QUIT
WRITE !,^(ZZ,0)
End DoDot:1
QUIT
+5 IF DA=""
WRITE "...At the Top.."
SET DA=9999999999
+6 QUIT
NEXT(DA) ;
+1 FOR
SET DA=$ORDER(^HL(772,DA))
if DA'>0
QUIT
IF $PIECE($GET(^HL(772,DA,0)),"^",2)=ZX
Begin DoDot:1
+2 SET DGHMID=$PIECE(^HL(772,DA,0),"^",8)
SET DGMESS=$ORDER(^HLMA("B",DGHMID,0))
if DGMESS=""
QUIT
+3 WRITE !,"Message ID: ",$PIECE($GET(^HLMA(+DGMESS,0)),"^",2)
+4 SET ZZ=0
FOR
SET ZZ=$ORDER(^HL(772,DA,"IN",ZZ))
if ZZ'>0
QUIT
WRITE !,^(ZZ,0)
End DoDot:1
QUIT
+5 IF DA'>0
WRITE "...Bottomed out.."
SET DA=99999999999
+6 QUIT
+7 ;
GETDIV(X) ;GET DIVISION FOR SPECIFIED WARD
+1 ;
+2 ;X = Ward IEN
+3 if $GET(X)=""
QUIT -1
+4 SET X=$$GET1^DIQ(42,X,.015,"I")
+5 QUIT X
+6 ;
CKADMIT(DFN) ;CHECH IF INTEGRATED SITE FOR ORIGINAL ADMIT DATE
+1 NEW DGASIH,DGINTEG,DGZDT,DGNDT,DGPMDA,DGQ
+2 SET (DGZDT,DGNDT)=""
+3 SET DGQ=0
+4 FOR
SET DGZDT=$ORDER(^DGPM("APTT1",DFN,DGZDT),-1)
if DGZDT=""
QUIT
Begin DoDot:1
+5 SET DGPMDA=$ORDER(^DGPM("APTT1",DFN,DGZDT,0))
+6 SET DGASIH=$$GET1^DIQ(405,DGPMDA,.22,"I")
+7 if DGASIH>0
QUIT
+8 SET DGNDT=$$GET1^DIQ(405,DGPMDA,300,"I")
SET DGQ=1
End DoDot:1
if DGQ=1
QUIT
+9 QUIT DGNDT
+10 ;
FLLTCM(DFN) ;
+1 ;Find last movement before patient goes ASIH
+2 ;p-430
NEW DGLASTA,DGLASTT,DGTIEN,DGLTCA,DGLTCIEN
+3 ;p-430
SET DGTIEN=""
+4 ;p-430
if DFN=""
GOTO QUIT
+5 ;If not inpatient, was ASIH to other facility. Get transfer movement
+6 IF '$DATA(^DPT(DFN,.1))
SET DGTIEN=$ORDER(^DGPM("APTT2",DFN,DGTIEN),-1)
SET DGTIEN=$ORDER(^DGPM("APTT2",DFN,DGTIEN,0))
GOTO QUIT
+7 ;
+8 ;Get last Admision
+9 ;p-430
SET DGLASTA=$ORDER(^DGPM("APTT1",DFN,""),-1)
+10 ;
+11 ;Quit if last admit not to ASIH (date length less than 15 characters)
+12 ;p-430
if DGLASTA=""!($LENGTH(DGLASTA)'=15)
GOTO QUIT
+13 ;
+14 ;Get LTC admit ien
+15 ;p-430
SET DGLTCA=$ORDER(^DGPM("APTT1",DFN,DGLASTA),-1)
+16 ;p-430
if DGLTCA=""
GOTO QUIT
+17 ;p-430
SET DGLTCIEN=$ORDER(^DGPM("APTT1",DFN,DGLTCA,0))
+18 ;
+19 ;Look for last transfer before ASIH admit
+20 ;p-430
SET DGLASTT=$EXTRACT(DGLASTA,1,14)_"1"
+21 ;p-430
SET DGTIEN=$ORDER(^DGPM("APTT2",DFN,DGLASTT),-1)
+22 ;
+23 ;If no transfers use admit movement
+24 ;p-430
IF DGTIEN=""
SET DGTIEN=DGLTCIEN
GOTO QUIT
+25 ;p-430
SET DGTIEN=$ORDER(^DGPM("APTT2",DFN,DGTIEN,0))
+26 ;p-430
IF $PIECE(^DGPM(DGTIEN,0),"^",14)'=DGLTCIEN
SET DGTIEN=DGLTCIEN
GOTO QUIT
QUIT QUIT DGTIEN
+1 ;
