source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUUTL1.m@ 1607

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
 ;