- 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 Feb 19, 2025@00:24:45 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 ;