Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGRUUTL1

DGRUUTL1.m

Go to the documentation of this file.
  1. DGRUUTL1 ;ALB/GRR - RAI/MDS UTILITY ROUTINE
  1. ;;5.3;Registration;**190,312,328,373,434,430,464**;Aug 13, 1993
  1. EN ;Process each division for routing
  1. N DGRDIV,DGDIV ;New all variables used
  1. K HLL ;Kill HLL which is used for an array
  1. S DGDIV=$$ENGET^DGRUGMFU()
  1. D ENMFU^DGRUDYN("MFU",DGDIV) ;Do API which gets subscriber(s) for the division
  1. Q
  1. ;
  1. LOCTRAN(DGPV1) ;TRANSLATE WARD AND ROOM-BED
  1. N DGCW,DGPW,DGPR,DGPB,DGW,DGR,DGB,DGPL,DGLOC,DGI,DGCRB,DGPRB ;modified p-373
  1. S DGLOC=$P(DGPV1,HL("FS"),4),DGPLOC=$P(DGPV1,HL("FS"),7)
  1. S DGW=$P(DGLOC,$E(HL("ECH"))),DGR=$P(DGLOC,$E(HL("ECH")),2),DGB=$P(DGLOC,$E(HL("ECH")),3)
  1. S DGPWN=$P(DGPLOC,$E(HL("ECH"))),DGPR=$P(DGPLOC,$E(HL("ECH")),2),DGPB=$P(DGPLOC,$E(HL("ECH")),3)
  1. N DGETYPE S DGETYPE=$P($G(@DGARRAY@(1)),HL("FS"),2) G:DGETYPE="" LOCEX
  1. ;
  1. I DGETYPE="A01" D
  1. .S DGCW=$P($G(DGPMA),"^",6),(DGPW,DGPWN,DGPR,DGPB)=""
  1. .S DGCRB=$P($G(DGPMA),"^",7),DGPRB=""
  1. ;
  1. I DGETYPE="A02" D
  1. .S DGCW=$P($G(DGPMA),"^",6),DGPW=$P($G(DGPMVI(5)),"^")
  1. .S DGCRB=$P($G(DGPMA),"^",7),DGPRB=$P($G(DGPMVI(6)),"^")
  1. .I $G(DGBS)=1 D ;p-464 BED SWITCH
  1. ..S DGPWN=DGW,DGPW=DGCW,DGPRBN=$P($G(DGPMVI(6)),"^",2) ;p-464
  1. ..S DGPR=$P(DGPRBN,"-",1),DGPB=$P(DGPRBN,"-",2) ;p-464
  1. .I DGPW=""!(DGPRB="") S DGPW=DGCW,DGPRB=DGCRB
  1. ;
  1. I DGETYPE="A03" D
  1. .I $G(DGXFR0)]"" D
  1. ..S (DGCW,DGPW)=$P(DGXFR0,"^",6)
  1. ..S (DGCRB,DGPRB)=$P(DGXFR0,"^",7)
  1. .I $G(DGPMAN)]"" D
  1. ..S (DGCW,DGPW)=$P(DGPMAN,"^",6)
  1. ..S (DGCRB,DGPRB)=$P(DGPMAN,"^",7)
  1. .I $G(DGPMVI(5))]"" D
  1. ..S (DGCW,DGPW)=$P($G(DGPMVI(5)),"^")
  1. ..S (DGCRB,DGPRB)=$P($G(DGPMVI(6)),"^")
  1. .I $G(DGMOVE)=47 D ;p-430
  1. ..S (DGCW,DGPW)=$P($G(DGRU(17,4)),"^") ;p-430
  1. ..S (DGCRB,DGPRB)=$P($G(DGRU(17,4)),"^",2) ;p-430
  1. ;
  1. I DGETYPE="A08" D
  1. .N VAIP D IN5^VADPT
  1. .S DGCW=+$G(VAIP(5)),DGPW=+$G(VAIP(15,4))
  1. .S DGCRB=+$G(VAIP(6)),DGPRB=""
  1. .N DGMIEN S DGMIEN=+$G(VAIP(15)) I DGMIEN>0 S DGPRB=$$GET1^DIQ(405,DGMIEN,.07,"I") K DGMIEN
  1. ;
  1. I DGETYPE="A11" D
  1. .S (DGCW,DGPW)=$P($G(DGPMVI(5)),"^")
  1. .S (DGCRB,DGPRB)=$P($G(DGPMVI(6)),"^")
  1. ;
  1. I DGETYPE="A12" D
  1. .S (DGCW,DGPW)=$P($G(DGPM0),"^",6),DGPWN=DGW
  1. .S (DGCRB,DGPRB)=$P($G(DGPM0),"^",7),DGPR=DGR,DGPB=DGB
  1. ;
  1. I DGETYPE="A13" D
  1. .S (DGCW,DGPW)=$P($G(DGPM0),"^",6),DGPWN=DGW
  1. .S (DGCRB,DGPRB)=$P($G(DGPM0),"^",7),DGPR=DGR,DGPB=DGB
  1. ;
  1. I DGETYPE="A21" D ;modified p-373
  1. .I $G(DGPMVI(5))]"" D Q
  1. ..S (DGCW,DGPW)=$P($G(DGPMVI(5)),"^")
  1. ..S (DGCRB,DGPRB)=$P($G(DGPMVI(6)),"^")
  1. .I $G(DGPMA)]"" D ;p-434
  1. ..S (DGCW,DGPW)=$P(DGPMA,"^",6) ;p-434
  1. ..S (DGCRB,DGPRB)=$P(DGPMA,"^",7) ;p-434
  1. .I $G(DGPMAN)]"" D
  1. ..S DGCW=$P($G(DGPMA),"^",6),DGPW=$P($G(DGPMAN),"^",6)
  1. ..S DGCRB=$P($G(DGPMA),"^",7),DGPRB=$P($G(DGPMAN),"^",7)
  1. I DGETYPE="A22" D ;added p-373
  1. .I $G(TRSNODE)]"" D Q ;added p-373
  1. ..S DGCW=$P($G(TRSNODE),"^",6),DGPW=$P($G(TRSNODE),"^",6) ;added p-373
  1. ..S DGCRB=$P($G(TRSNODE),"^",7),DGPRB=$P($G(TRSNODE),"^",7) ;added p-373
  1. .I $P($G(DGPMVI(5)),"^")]""&($P($G(DGPMVI(6)),"^")]"") D Q ;added p-373,p-430
  1. ..S (DGCW,DGPW)=$P($G(DGPMVI(5)),"^") ;added p-373
  1. ..S (DGCRB,DGPRB)=$P($G(DGPMVI(6)),"^") ;added p-373
  1. .I $D(VAFH(2,DGMIEN,"A")) D ;added p-373
  1. ..S (DGCW,DGPW)=$P(VAFH(2,DGMIEN,"A"),"^",6) ;added p-373
  1. ..S (DGCRB,DGPRB)=$P(VAFH(2,DGMIEN,"A"),"^",7) ;added p-373
  1. SKIP1 ;
  1. S DGNW=$$WARDTRAN(DGCW,DGW)
  1. S DGNRB=$$RBTRAN(DGCRB,DGR_"-"_DGB)
  1. S DGNPW=$$WARDTRAN(DGPW,DGPWN)
  1. S DGNPRB=$$RBTRAN(DGPRB,DGPR_"-"_DGPB)
  1. 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))
  1. S $P(DGPV1,HL("FS"),4)=DGNLOC,$P(DGPV1,HL("FS"),7)=DGNPLOC
  1. LOCEX Q DGPV1
  1. ;
  1. WARDTRAN(DGWIEN,DGWNAM) ;
  1. I DGWNAM=""!(DGWNAM=HLQ)!(DGWIEN="") Q DGWNAM
  1. S DGCI=$O(^DGRU(46.12,"B",DGWIEN,0)) I DGCI="" Q DGWNAM
  1. S DGTNW=$$GET1^DIQ(46.12,DGCI,.02,"I")
  1. Q DGTNW
  1. RBTRAN(DGRBIEN,DGRBNAM) ;
  1. I DGRBNAM=""!(DGRBNAM[HLQ)!(DGRBIEN="") Q DGRBNAM
  1. S DGCI=$O(^DGRU(46.13,"B",DGRBIEN,0)) I DGCI="" Q DGRBNAM
  1. S DGRB=$$GET1^DIQ(46.13,DGCI,.02,"I")
  1. Q DGRB
  1. ;
  1. DOCTOR(X) ;DETERMINE IF NEW PERSON A PHYSICIAN ;added 1/12/2000
  1. Q 0 ;always flag as non-physician, no need to send these anymore
  1. S DGPCN=$$GET1^DIQ(7,X,.01,"I")
  1. Q DGPCN["PHYSICIAN"
  1. ;
  1. IN1(DFN) ;CREATE IN1 SEGMENT
  1. N DGADT,DGREC,VAIP
  1. D IN5^VADPT
  1. S DGADT=$S(VAIP(13,1)]"":+$P(VAIP(13,1),"^"),1:"") I DGADT]"" S DGADT=DGADT\1,DGADT=$$HLDATE^HLFNC(DGADT)
  1. S DGREC="IN1"_HL("FS")_HL("FS")_HL("FS")_"VA"_HL("FS")_"VETERANS ADMINISTRATION"
  1. S $P(DGREC,HL("FS"),13)=DGADT
  1. Q DGREC
  1. ;
  1. CALCDT(DFN,DGMIEN) ;CALCULATE FUTURE DISCHARGE DATE
  1. N DGOIEN,DGOLDD,DGDT,DGHDT
  1. S Z=$O(^DGPM("ATID2",DFN,0)),DGOIEN=$O(^DGPM("ATID2",DFN,Z,DGMIEN))
  1. S DGOLDD=$$GET1^DIQ(405,DGOIEN,.01,"I")
  1. S X1=DGOLDD,X2=30 D C^%DTC S DGDT=X,DGHDT=$$HLDATE^HLFNC(DGDT)
  1. Q DGHDT
  1. ;
  1. ENTS ;USED TO REVIEW HL7 MESSAGES FOR TROUBLE SHOOTING
  1. N DA,X,ZZ,ZX
  1. N DIC,Y S DIC=771,DIC(0)="MX",X="DGRU RAI EVENTS" D ^DIC S ZX=+Y
  1. I Y<0 W !,"The 'DGRU RAI EVENTS' entry in file 771 missing!" Q
  1. S DA=999999999999
  1. D PRIOR(.DA)
  1. RD2 S DIR(0)="F^1:1",DIR("A")="(U)p or (D)own" D ^DIR K DIR
  1. I X="U" D PRIOR(.DA) G RD2
  1. I X="D" D NEXT(.DA) G RD2
  1. Q
  1. ;
  1. PRIOR(DA) ;
  1. F S DA=$O(^HL(772,DA),-1) Q:DA="" I $P($G(^HL(772,DA,0)),"^",2)=ZX D Q
  1. .S DGHMID=$P(^HL(772,DA,0),"^",8),DGMESS=$O(^HLMA("B",DGHMID,0)) Q:DGMESS=""
  1. .W !,"Message ID: ",$P($G(^HLMA(+DGMESS,0)),"^",2)
  1. .S ZZ=0 F S ZZ=$O(^HL(772,DA,"IN",ZZ)) Q:ZZ'>0 W !,^(ZZ,0)
  1. I DA="" W "...At the Top.." S DA=9999999999
  1. Q
  1. NEXT(DA) ;
  1. F S DA=$O(^HL(772,DA)) Q:DA'>0 I $P($G(^HL(772,DA,0)),"^",2)=ZX D Q
  1. .S DGHMID=$P(^HL(772,DA,0),"^",8),DGMESS=$O(^HLMA("B",DGHMID,0)) Q:DGMESS=""
  1. .W !,"Message ID: ",$P($G(^HLMA(+DGMESS,0)),"^",2)
  1. .S ZZ=0 F S ZZ=$O(^HL(772,DA,"IN",ZZ)) Q:ZZ'>0 W !,^(ZZ,0)
  1. I DA'>0 W "...Bottomed out.." S DA=99999999999
  1. Q
  1. ;
  1. GETDIV(X) ;GET DIVISION FOR SPECIFIED WARD
  1. ;
  1. ;X = Ward IEN
  1. Q:$G(X)="" -1
  1. S X=$$GET1^DIQ(42,X,.015,"I")
  1. Q X
  1. ;
  1. CKADMIT(DFN) ;CHECH IF INTEGRATED SITE FOR ORIGINAL ADMIT DATE
  1. N DGASIH,DGINTEG,DGZDT,DGNDT,DGPMDA,DGQ
  1. S (DGZDT,DGNDT)=""
  1. S DGQ=0
  1. F S DGZDT=$O(^DGPM("APTT1",DFN,DGZDT),-1) Q:DGZDT="" D Q:DGQ=1
  1. .S DGPMDA=$O(^DGPM("APTT1",DFN,DGZDT,0))
  1. .S DGASIH=$$GET1^DIQ(405,DGPMDA,.22,"I")
  1. .Q:DGASIH>0
  1. .S DGNDT=$$GET1^DIQ(405,DGPMDA,300,"I"),DGQ=1
  1. Q DGNDT
  1. ;
  1. FLLTCM(DFN) ;
  1. ;Find last movement before patient goes ASIH
  1. N DGLASTA,DGLASTT,DGTIEN,DGLTCA,DGLTCIEN ;p-430
  1. S DGTIEN="" ;p-430
  1. G:DFN="" QUIT ;p-430
  1. ;If not inpatient, was ASIH to other facility. Get transfer movement
  1. I '$D(^DPT(DFN,.1)) S DGTIEN=$O(^DGPM("APTT2",DFN,DGTIEN),-1),DGTIEN=$O(^DGPM("APTT2",DFN,DGTIEN,0)) G QUIT
  1. ;
  1. ;Get last Admision
  1. S DGLASTA=$O(^DGPM("APTT1",DFN,""),-1) ;p-430
  1. ;
  1. ;Quit if last admit not to ASIH (date length less than 15 characters)
  1. G:DGLASTA=""!($L(DGLASTA)'=15) QUIT ;p-430
  1. ;
  1. ;Get LTC admit ien
  1. S DGLTCA=$O(^DGPM("APTT1",DFN,DGLASTA),-1) ;p-430
  1. G:DGLTCA="" QUIT ;p-430
  1. S DGLTCIEN=$O(^DGPM("APTT1",DFN,DGLTCA,0)) ;p-430
  1. ;
  1. ;Look for last transfer before ASIH admit
  1. S DGLASTT=$E(DGLASTA,1,14)_"1" ;p-430
  1. S DGTIEN=$O(^DGPM("APTT2",DFN,DGLASTT),-1) ;p-430
  1. ;
  1. ;If no transfers use admit movement
  1. I DGTIEN="" S DGTIEN=DGLTCIEN G QUIT ;p-430
  1. S DGTIEN=$O(^DGPM("APTT2",DFN,DGTIEN,0)) ;p-430
  1. I $P(^DGPM(DGTIEN,0),"^",14)'=DGLTCIEN S DGTIEN=DGLTCIEN G QUIT ;p-430
  1. QUIT Q DGTIEN
  1. ;