TIULV.m

TIULV ; SLC/JER - Visit/Movement related library ;29-Apr-2014 15:01;DU

 ;;1.0;TEXT INTEGRATION UTILITIES;**7,30,55,45,52,148,156,152,113,1001,1007,1009,200,1011,1012**;Jun 20, 1997;Build 45

 ;IHS/ITSC/LJF 02/26/2003 set chart #, visit and facility fields

 ;     used file DD to determine service category external format

 ;             04/08/2004 fixed code to prevent UNDEF if no ward

 ;IHS/ITSC/LJF 11/05/2004 PATCH 1001 if called by EHR, BTIUVSIT may not be set

PATPN(TIUY,DFN) ; Get minimum demographics for PN Print

 N VADM,VAIP,VAIN,VA,VAPA

 D OERR^VADPT

 S TIUY("PNMP")=$E($G(VADM(1)),1,30)

 S TIUY("SSN")=$G(VA("PID"))

 S TIUY("HRCN")=$G(HRCN)                   ;IHS/ITSC/LJF 02/26/2003 set chart#

 S TIUY("DOB")="DOB:"_$$DATE^TIULS(+$G(VADM(3)),"MM/DD/CCYY")

 D ADD^VADPT

 I $G(VAPA(8))'="" S TIUY("PH#")="Ph:"_VAPA(8)

 I $G(VAPA(8))="" S TIUY("PH#")="Ph: **UNKNOWN**"

 S TIUY("INTNM")=$$NAME^VASITE ;Integration Name

 ;S TIUY("SITE")=$P($$SITE^VASITE,U,2)     ;IHS/ITSC/LJF 02/26/2003

 S TIUY("SITE")=$$GET1^DIQ(4,DUZ(2),.01)   ;IHS/ITSC/LJF 02/26/2003 get facility name

 S TIUY("LOCP")="Pt Loc: "_$S(VAIN(4)]"":$P(VAIN(4),U,2)_"  "_VAIN(5),1:"OUTPATIENT")

 Q

 ;

PATVADPT(TIUY,DFN,TIUMVN,TIUVSTR,TIUSDC) ; Extract MAS data

 N VA,VADM,VAEL,VAERR,VAIP,TIUI,TIUWARD,X,Y,TIUTYPE,TIUFTS,TIUSS,VAPA

 D DEM^VADPT

 S TIUY("PNM")=$G(VADM(1)),TIUY("SSN")=$G(VA("PID"))

 S TIUY("HRCN")=$G(HRCN)  ;IHS/ITSC/LJF 02/26/2003 set chart #

 S TIUY("AGE")=$G(VADM(4)),TIUY("PID")="("_$E(TIUY("PNM"))_VA("BID")_")"

 S TIUY("DOB")=$G(VADM(3))

 D ADD^VADPT

 I $G(VAPA(8))'="" S TIUY("PH#")=VAPA(8)

 I $G(VAPA(8))="" S TIUY("PH#")="**UNKNOWN**"

 S TIUY("SEX")=$G(VADM(5))

 ; Below TIU*148

 I +$G(VADM(12))>0 D

 . F TIUY("NUMRACE")=1:1:VADM(12) S TIUY("RACE",TIUY("NUMRACE"))=$G(VADM(12,TIUY("NUMRACE")))

 S TIUY("RACENO")=+$G(VADM(12))

 I +$G(VADM(12))=0 S TIUY("RACE")=$G(VADM(8))

 I +$G(TIUSDC) S TIUY("STOP")=$G(TIUSDC)

 I +$G(TIUD13(0)) S TIUY("REFDT")=+$G(TIUD13(0))

 I +$G(TIUMVN),$D(^DGPM(+TIUMVN)) D

 . ; N VLOC,VDT,TIUDIV

 . N VLOC,VDT,TIUDIV

 . S VAIP("E")=TIUMVN D 52^VADPT

 . S TIUI=$S(+$G(VAIP(17,1)):17,1:14)

 . S TIUY("CLAIM")=$G(VAEL(7)),TIUY("PMD")=$G(VAIP(TIUI,5))

 . S TIUY("AMD")=$G(VAIP(18)),TIUY("TS")=$G(VAIP(TIUI,6))

 . S TIUY("SVC")=+$$GET1^DIQ(45.7,+TIUY("TS"),2,"I",,"ERROR")

 . S TIUY("SVC")=TIUY("SVC")_U_$$GET1^DIQ(49,+TIUY("SVC"),.01,"I",,"ERROR")

 . S TIUY("WARD")=$$WARD($G(VAIP(17)))

 . S (TIUY("ADDT"),TIUY("EDT"))=$G(VAIP(3))

 . I +TIUY("WARD") S TIUY("LOC")=$G(^DIC(42,+TIUY("WARD"),44))

 . I +$G(TIUY("LOC")) D

 . . S TIUY("LOC")=TIUY("LOC")_U_$P($G(^SC(+TIUY("LOC"),0)),U)

 . S TIUY("ADDX")=$G(VAIP(9)),TIUY("LDT")=$G(VAIP(17,1))

 . S TIUY("AD#")=+$G(VAIP(13)),TIUY("MTYPE")=$G(VAIP(TIUI,3))

 . S TIUDIV=$P($G(^DIC(42,+TIUY("WARD"),0)),U,11)

 . I +TIUDIV S TIUY("DIV")=TIUDIV_U_$P($G(^DG(40.8,+TIUDIV,0)),U)

 . S VDT=+VAIP(3)

 . S VLOC=$G(^DIC(42,+$P($G(VAIP(13,4)),U),44))

 . S TIUY("VSTR")=VLOC_";"_+TIUY("EDT")_";H"

 . ;S TIUY("VLOC")=VLOC_U_$P($G(^SC(VLOC,0)),U)    ;IHS/ITSC/LJF

 . S TIUY("VLOC")=VLOC_U_$P($G(^SC(+VLOC,0)),U)   ;IHS/ITSC/LJF 4/8/2004 prevent UNDEF

 . S:'+$G(TIUY("LOC")) TIUY("LOC")=TIUY("VLOC")

 I $G(TIUVSTR)]"" S TIUY("VSTR")=TIUVSTR D VSIT(.TIUY,TIUVSTR)

 I '+$G(TIUMVN),'+$G(TIUVSTR) D CURRENT(.TIUY,DFN)

 ; D CURRENT(.TIUY,DFN)

 I +$$PROVIDER^TIUPXAP1($S($D(TIUAUTH):+$G(TIUAUTH),1:DUZ),+$G(TIUY("EDT"))) D

 . S TIUY("SVC")=$$PROVSVC(+$S($D(TIUAUTH):+$G(TIUAUTH),1:DUZ))

 I +$G(TIUY("VSTR")),(+$O(^TIU(8925,"AVSTRV",+DFN,$G(TIUY("VSTR")),0))>0) D

 . N TIUVSIT S TIUVSIT=+$O(^TIU(8925,"AVSTRV",+DFN,$G(TIUY("VSTR")),0))

 . I $P($G(^AUPNVSIT(+TIUVSIT,0)),U,5)'=DFN K ^TIU(8925,"AVSTRV",+DFN,$G(TIUY("VSTR")),TIUVSIT) Q

 . S TIUY("VISIT")=+TIUVSIT_U_+$G(^AUPNVSIT(+TIUVSIT,0))

 ;

 ;IHS/ITSC/LJF 02/26/2003 setting of variables from IHS data

 I '$G(BTIUVSIT),$G(TIUMVN) NEW BTIUVSIT S BTIUVSIT=$$GET1^DIQ(405,TIUMVN,.27,"I")  ;visit ien

 ;IHS/ITSC/LJF 11/05/2004 PATCH 1001 if called by EHR, BTIUVSIT may not be set

 I $G(BTIUVSIT)<1,$G(TIUVSIT)>0 S TIUY("VISIT")=(+TIUVSIT)_U_+$G(^AUPNVSIT(+TIUVSIT,0))

 E  S TIUY("VISIT")=+$G(BTIUVSIT)_U_+$G(^AUPNVSIT(+$G(BTIUVSIT),0))

 ;end of PATCH 1001 change

 ;

 I '$D(TIUY("DIV")) S TIUY("DIV")=+$O(^DG(40.8,"AD",DUZ(2),0))_U_$$GET1^DIQ(4,DUZ(2),.01)  ;IHS/MSC/MGH Patch 1012

 ;IHS/ITSC/LJF 02/26/2003 end of new code

 ;

 ; if pt an inpt + doc class is pn- default to current inpt loc

 S TIUTYPE=$S(+$P($G(TIUTYP(1)),U,2)>0:$P($G(TIUTYP(1)),U,2),1:+$G(TIUTYP))

 I +TIUTYPE'>0 S TIUY("INST")=$$DIVISION^TIULC1(+TIUY("LOC")) Q

 I +$G(TIUMVN),$D(^DPT(DFN,.1)),+$$ISPN^TIULX(TIUTYPE) D

 . I $D(VAIP(14,4)) S TIUY("LOC")=$G(^DIC(42,+VAIP(14,4),44))_U_$P(VAIP(14,4),U,2)

 S TIUY("INST")=$$DIVISION^TIULC1(+TIUY("LOC"))

 Q

WARD(DA) ; Compute ward at discharge

 N %,D0,DIC,DIQ,DR,MOVE,X,Y

 I +DA'>0 S Y=$G(VAIP(TIUI,4)) G WARDX

 S DIC="^DGPM(",DIQ(0)="IE",DIQ="MOVE(",DR=200

 D EN^DIQ1

 S X=$G(MOVE(405,DA,200,"E")),DIC=42,DIC(0)="X" D ^DIC

 I +Y'>0 S Y=""

WARDX Q Y

PROVSVC(TIUSER) ; Resolve user's Service

 N TIUY

 S TIUY=$P($G(^VA(200,+TIUSER,5)),U)

 S:+TIUY TIUY=TIUY_U_$P(^DIC(49,+TIUY,0),U)

 Q TIUY

VSIT(TIUY,TIUVSTR) ; Get Visit related info

 N DIC,DIQ,X,Y,DA,DR,VSIT,TIUCT,VAEL,VAERR

 D ELIG^VADPT

 I '$D(TIUY("EDT")) D

 . S TIUY("EDT")=$P(TIUVSTR,";",2)_U_$$DATE^TIULS($P(TIUVSTR,";",2),"AMTH DD, CCYY@HR:MIN")

 S TIUY("LDT")=$G(TIUY("LDT"))

 S TIUCT=$P(TIUVSTR,";",3)

 ;I TIUCT]"" S TIUY("CAT")=TIUCT_U_$S(TIUCT="A":"AMBULATORY",TIUCT="I":"IN HOSPITAL",TIUCT="H":"HOSPITALIZATION",TIUCT="T":"TELEPHONE",1:"EVENT (HISTORICAL)")

 I TIUCT]"" NEW C,Y S C=$P(^DD(9000010,.07,0),U,2),Y=TIUCT D Y^DIQ S TIUY("CAT")=TIUCT_U_Y   ;IHS/ITSC/LJF 02/26/2003 use all possible choices in file

 I TIUCT="E",+$G(TIUVSTR)'>0 Q

 S TIUY("LVL")=$G(TIUY("LVL"))

 S TIUY("ELG")=$G(VAEL(1))

 S TIUY("VLOC")=+$G(TIUVSTR)_U_$P($G(^SC(+$G(TIUVSTR),0)),U)

 I $G(TIUY("LOC"))']"" S TIUY("LOC")=$S($L($G(TIUD12)):$P($G(TIUD12),U,5),+$G(TIUDA):+$P($G(^TIU(8925,+$G(TIUDA),12)),U,5),1:+TIUY("VLOC"))

 S:$P(TIUY("LOC"),U,2)']"" TIUY("LOC")=TIUY("LOC")_U_$P($G(^SC(+TIUY("LOC"),0)),U)

 I '$D(TIUY("DIV")),+$G(TIUY("LOC")) D

 . N TIUDIV,DIC,DR,DA,DIQ,X,Y

 . S DIC=44,DIQ="TIUDIV",DIQ(0)="IE",DA=+TIUY("LOC"),DR="3.5" D EN^DIQ1

 . I '+$G(TIUDIV(44,+DA,3.5,"I")) Q

 . S TIUY("DIV")=TIUDIV(44,+DA,3.5,"I")_U_TIUDIV(44,+DA,3.5,"E")

 I '$D(TIUY("DIV")),'+$G(TIUY("LOC")) D

 . S TIUY("DIV")=+$O(^DG(40.8,"AD",+$G(DUZ(2)),0))

 . S TIUY("DIV")=+TIUY("DIV")_U_$P($G(^DG(40.8,+$G(TIUY("DIV")),0)),U)

 S TIUY("INS")=$G(TIUY("DIV"))

 S TIUY("SC")=$G(TIUY("SC"))

 Q

CURRENT(TIUY,DFN) ; Get current INPATIENT data

 N VAIN D INP^VADPT

 S TIUY("AD#")=$G(VAIN(1)),TIUY("PMD")=$G(VAIN(2))

 S TIUY("TS")=$G(VAIN(3)),TIUY("WARD")=$G(VAIN(4),"0^OUTPATIENT")

 S TIUY("RB")=$G(VAIN(5))

 I +TIUY("WARD") D

 . N DIC,DIQ,DR,DA,TIUDIV,Y

 . S DIC=42,DA=+TIUY("WARD"),DIQ="TIUDIV(",DIQ(0)="IE",DR=".015;44"

 . D EN^DIQ1

 . S TIUY("DIV")=$G(TIUDIV(42,DA,.015,"I"))_U_$G(TIUDIV(42,DA,.015,"E"))

 . S TIUY("LOC")=$G(TIUDIV(42,DA,44,"I"))_U_$G(TIUDIV(42,DA,44,"E"))

 S TIUY("LOC")=$G(TIUY("LOC"))

 I '+$G(TIUY("DIV")) D

 . N DIC,DIQ,DR,DA

 . S DIC=4,DR=".01",DA=+$G(DUZ(2)),DIQ="TIUDIV1"

 . D EN^DIQ1

 . ;TIU*1*152 changed TIUDIV1(4,DUZ(2),.01) to $G(TIUDIV1(4,$G(DUZ(2)),.01)) ; TIU*1*200 Added + to 2nd piece and + to $G(DUZ(2))

 . S TIUY("DIV")=+$G(DUZ(2))_U_+$G(TIUDIV1(4,+$G(DUZ(2)),.01))

 Q

TIULV     ; SLC/JER - Visit/Movement related library ;29-Apr-2014 15:01;DU

 +1       ;;1.0;TEXT INTEGRATION UTILITIES;**7,30,55,45,52,148,156,152,113,1001,1007,1009,200,1011,1012**;Jun 20, 1997;Build 45

 +2       ;IHS/ITSC/LJF 02/26/2003 set chart #, visit and facility fields

 +3       ;     used file DD to determine service category external format

 +4       ;             04/08/2004 fixed code to prevent UNDEF if no ward

 +5       ;IHS/ITSC/LJF 11/05/2004 PATCH 1001 if called by EHR, BTIUVSIT may not be set

PATPN(TIUY,DFN) ; Get minimum demographics for PN Print

 +1        NEW VADM,VAIP,VAIN,VA,VAPA

 +2        DO OERR^VADPT

 +3        SET TIUY("PNMP")=$EXTRACT($GET(VADM(1)),1,30)

 +4        SET TIUY("SSN")=$GET(VA("PID"))

 +5       ;IHS/ITSC/LJF 02/26/2003 set chart#

           SET TIUY("HRCN")=$GET(HRCN)

 +6        SET TIUY("DOB")="DOB:"_$$DATE^TIULS(+$GET(VADM(3)),"MM/DD/CCYY")

 +7        DO ADD^VADPT

 +8        IF $GET(VAPA(8))'=""

               SET TIUY("PH#")="Ph:"_VAPA(8)

 +9        IF $GET(VAPA(8))=""

               SET TIUY("PH#")="Ph: **UNKNOWN**"

 +10      ;Integration Name

           SET TIUY("INTNM")=$$NAME^VASITE

 +11      ;S TIUY("SITE")=$P($$SITE^VASITE,U,2)     ;IHS/ITSC/LJF 02/26/2003

 +12      ;IHS/ITSC/LJF 02/26/2003 get facility name

           SET TIUY("SITE")=$$GET1^DIQ(4,DUZ(2),.01)

 +13       SET TIUY("LOCP")="Pt Loc: "_$SELECT(VAIN(4)]"":$PIECE(VAIN(4),U,2)_"  "_VAIN(5),1:"OUTPATIENT")

 +14       QUIT 

 +15      ;

PATVADPT(TIUY,DFN,TIUMVN,TIUVSTR,TIUSDC) ; Extract MAS data

 +1        NEW VA,VADM,VAEL,VAERR,VAIP,TIUI,TIUWARD,X,Y,TIUTYPE,TIUFTS,TIUSS,VAPA

 +2        DO DEM^VADPT

 +3        SET TIUY("PNM")=$GET(VADM(1))

           SET TIUY("SSN")=$GET(VA("PID"))

 +4       ;IHS/ITSC/LJF 02/26/2003 set chart #

           SET TIUY("HRCN")=$GET(HRCN)

 +5        SET TIUY("AGE")=$GET(VADM(4))

           SET TIUY("PID")="("_$EXTRACT(TIUY("PNM"))_VA("BID")_")"

 +6        SET TIUY("DOB")=$GET(VADM(3))

 +7        DO ADD^VADPT

 +8        IF $GET(VAPA(8))'=""

               SET TIUY("PH#")=VAPA(8)

 +9        IF $GET(VAPA(8))=""

               SET TIUY("PH#")="**UNKNOWN**"

 +10       SET TIUY("SEX")=$GET(VADM(5))

 +11      ; Below TIU*148

 +12       IF +$GET(VADM(12))>0

               Begin DoDot:1

 +13               FOR TIUY("NUMRACE")=1:1:VADM(12)

                       SET TIUY("RACE",TIUY("NUMRACE"))=$GET(VADM(12,TIUY("NUMRACE")))

               End DoDot:1

 +14       SET TIUY("RACENO")=+$GET(VADM(12))

 +15       IF +$GET(VADM(12))=0

               SET TIUY("RACE")=$GET(VADM(8))

 +16       IF +$GET(TIUSDC)

               SET TIUY("STOP")=$GET(TIUSDC)

 +17       IF +$GET(TIUD13(0))

               SET TIUY("REFDT")=+$GET(TIUD13(0))

 +18       IF +$GET(TIUMVN)

               IF $DATA(^DGPM(+TIUMVN))

                   Begin DoDot:1

 +19      ; N VLOC,VDT,TIUDIV

 +20                   NEW VLOC,VDT,TIUDIV

 +21                   SET VAIP("E")=TIUMVN

                       DO 52^VADPT

 +22                   SET TIUI=$SELECT(+$GET(VAIP(17,1)):17,1:14)

 +23                   SET TIUY("CLAIM")=$GET(VAEL(7))

                       SET TIUY("PMD")=$GET(VAIP(TIUI,5))

 +24                   SET TIUY("AMD")=$GET(VAIP(18))

                       SET TIUY("TS")=$GET(VAIP(TIUI,6))

 +25                   SET TIUY("SVC")=+$$GET1^DIQ(45.7,+TIUY("TS"),2,"I",,"ERROR")

 +26                   SET TIUY("SVC")=TIUY("SVC")_U_$$GET1^DIQ(49,+TIUY("SVC"),.01,"I",,"ERROR")

 +27                   SET TIUY("WARD")=$$WARD($GET(VAIP(17)))

 +28                   SET (TIUY("ADDT"),TIUY("EDT"))=$GET(VAIP(3))

 +29                   IF +TIUY("WARD")

                           SET TIUY("LOC")=$GET(^DIC(42,+TIUY("WARD"),44))

 +30                   IF +$GET(TIUY("LOC"))

                           Begin DoDot:2

 +31                           SET TIUY("LOC")=TIUY("LOC")_U_$PIECE($GET(^SC(+TIUY("LOC"),0)),U)

                           End DoDot:2

 +32                   SET TIUY("ADDX")=$GET(VAIP(9))

                       SET TIUY("LDT")=$GET(VAIP(17,1))

 +33                   SET TIUY("AD#")=+$GET(VAIP(13))

                       SET TIUY("MTYPE")=$GET(VAIP(TIUI,3))

 +34                   SET TIUDIV=$PIECE($GET(^DIC(42,+TIUY("WARD"),0)),U,11)

 +35                   IF +TIUDIV

                           SET TIUY("DIV")=TIUDIV_U_$PIECE($GET(^DG(40.8,+TIUDIV,0)),U)

 +36                   SET VDT=+VAIP(3)

 +37                   SET VLOC=$GET(^DIC(42,+$PIECE($GET(VAIP(13,4)),U),44))

 +38                   SET TIUY("VSTR")=VLOC_";"_+TIUY("EDT")_";H"

 +39      ;S TIUY("VLOC")=VLOC_U_$P($G(^SC(VLOC,0)),U)    ;IHS/ITSC/LJF

 +40      ;IHS/ITSC/LJF 4/8/2004 prevent UNDEF

                       SET TIUY("VLOC")=VLOC_U_$PIECE($GET(^SC(+VLOC,0)),U)

 +41                   IF '+$GET(TIUY("LOC"))

                           SET TIUY("LOC")=TIUY("VLOC")

                   End DoDot:1

 +42       IF $GET(TIUVSTR)]""

               SET TIUY("VSTR")=TIUVSTR

               DO VSIT(.TIUY,TIUVSTR)

 +43       IF '+$GET(TIUMVN)

               IF '+$GET(TIUVSTR)

                   DO CURRENT(.TIUY,DFN)

 +44      ; D CURRENT(.TIUY,DFN)

 +45       IF +$$PROVIDER^TIUPXAP1($SELECT($DATA(TIUAUTH):+$GET(TIUAUTH),1:DUZ),+$GET(TIUY("EDT")))

               Begin DoDot:1

 +46               SET TIUY("SVC")=$$PROVSVC(+$SELECT($DATA(TIUAUTH):+$GET(TIUAUTH),1:DUZ))

               End DoDot:1

 +47       IF +$GET(TIUY("VSTR"))

               IF (+$ORDER(^TIU(8925,"AVSTRV",+DFN,$GET(TIUY("VSTR")),0))>0)

                   Begin DoDot:1

 +48                   NEW TIUVSIT

                       SET TIUVSIT=+$ORDER(^TIU(8925,"AVSTRV",+DFN,$GET(TIUY("VSTR")),0))

 +49                   IF $PIECE($GET(^AUPNVSIT(+TIUVSIT,0)),U,5)'=DFN

                           KILL ^TIU(8925,"AVSTRV",+DFN,$GET(TIUY("VSTR")),TIUVSIT)

                           QUIT 

 +50                   SET TIUY("VISIT")=+TIUVSIT_U_+$GET(^AUPNVSIT(+TIUVSIT,0))

                   End DoDot:1

 +51      ;

 +52      ;IHS/ITSC/LJF 02/26/2003 setting of variables from IHS data

 +53      ;visit ien

           IF '$GET(BTIUVSIT)

               IF $GET(TIUMVN)

                   NEW BTIUVSIT

                   SET BTIUVSIT=$$GET1^DIQ(405,TIUMVN,.27,"I")

 +54      ;IHS/ITSC/LJF 11/05/2004 PATCH 1001 if called by EHR, BTIUVSIT may not be set

 +55       IF $GET(BTIUVSIT)<1

               IF $GET(TIUVSIT)>0

                   SET TIUY("VISIT")=(+TIUVSIT)_U_+$GET(^AUPNVSIT(+TIUVSIT,0))

 +56      IF '$TEST

               SET TIUY("VISIT")=+$GET(BTIUVSIT)_U_+$GET(^AUPNVSIT(+$GET(BTIUVSIT),0))

 +57      ;end of PATCH 1001 change

 +58      ;

 +59      ;IHS/MSC/MGH Patch 1012

           IF '$DATA(TIUY("DIV"))

               SET TIUY("DIV")=+$ORDER(^DG(40.8,"AD",DUZ(2),0))_U_$$GET1^DIQ(4,DUZ(2),.01)

 +60      ;IHS/ITSC/LJF 02/26/2003 end of new code

 +61      ;

 +62      ; if pt an inpt + doc class is pn- default to current inpt loc

 +63       SET TIUTYPE=$SELECT(+$PIECE($GET(TIUTYP(1)),U,2)>0:$PIECE($GET(TIUTYP(1)),U,2),1:+$GET(TIUTYP))

 +64       IF +TIUTYPE'>0

               SET TIUY("INST")=$$DIVISION^TIULC1(+TIUY("LOC"))

               QUIT 

 +65       IF +$GET(TIUMVN)

               IF $DATA(^DPT(DFN,.1))

                   IF +$$ISPN^TIULX(TIUTYPE)

                       Begin DoDot:1

 +66                       IF $DATA(VAIP(14,4))

                               SET TIUY("LOC")=$GET(^DIC(42,+VAIP(14,4),44))_U_$PIECE(VAIP(14,4),U,2)

                       End DoDot:1

 +67       SET TIUY("INST")=$$DIVISION^TIULC1(+TIUY("LOC"))

 +68       QUIT 

WARD(DA)  ; Compute ward at discharge

 +1        NEW %,D0,DIC,DIQ,DR,MOVE,X,Y

 +2        IF +DA'>0

               SET Y=$GET(VAIP(TIUI,4))

               GOTO WARDX

 +3        SET DIC="^DGPM("

           SET DIQ(0)="IE"

           SET DIQ="MOVE("

           SET DR=200

 +4        DO EN^DIQ1

 +5        SET X=$GET(MOVE(405,DA,200,"E"))

           SET DIC=42

           SET DIC(0)="X"

           DO ^DIC

 +6        IF +Y'>0

               SET Y=""

WARDX      QUIT Y

PROVSVC(TIUSER) ; Resolve user's Service

 +1        NEW TIUY

 +2        SET TIUY=$PIECE($GET(^VA(200,+TIUSER,5)),U)

 +3        IF +TIUY

               SET TIUY=TIUY_U_$PIECE(^DIC(49,+TIUY,0),U)

 +4        QUIT TIUY

VSIT(TIUY,TIUVSTR) ; Get Visit related info

 +1        NEW DIC,DIQ,X,Y,DA,DR,VSIT,TIUCT,VAEL,VAERR

 +2        DO ELIG^VADPT

 +3        IF '$DATA(TIUY("EDT"))

               Begin DoDot:1

 +4                SET TIUY("EDT")=$PIECE(TIUVSTR,";",2)_U_$$DATE^TIULS($PIECE(TIUVSTR,";",2),"AMTH DD, CCYY@HR:MIN")

               End DoDot:1

 +5        SET TIUY("LDT")=$GET(TIUY("LDT"))

 +6        SET TIUCT=$PIECE(TIUVSTR,";",3)

 +7       ;I TIUCT]"" S TIUY("CAT")=TIUCT_U_$S(TIUCT="A":"AMBULATORY",TIUCT="I":"IN HOSPITAL",TIUCT="H":"HOSPITALIZATION",TIUCT="T":"TELEPHONE",1:"EVENT (HISTORICAL)")

 +8       ;IHS/ITSC/LJF 02/26/2003 use all possible choices in file

           IF TIUCT]""

               NEW C,Y

               SET C=$PIECE(^DD(9000010,.07,0),U,2)

               SET Y=TIUCT

               DO Y^DIQ

               SET TIUY("CAT")=TIUCT_U_Y

 +9        IF TIUCT="E"

               IF +$GET(TIUVSTR)'>0

                   QUIT 

 +10       SET TIUY("LVL")=$GET(TIUY("LVL"))

 +11       SET TIUY("ELG")=$GET(VAEL(1))

 +12       SET TIUY("VLOC")=+$GET(TIUVSTR)_U_$PIECE($GET(^SC(+$GET(TIUVSTR),0)),U)

 +13       IF $GET(TIUY("LOC"))']""

               SET TIUY("LOC")=$SELECT($LENGTH($GET(TIUD12)):$PIECE($GET(TIUD12),U,5),+$GET(TIUDA):+$PIECE($GET(^TIU(8925,+$GET(TIUDA),12)),U,5),1:+TIUY("VLOC"))

 +14       IF $PIECE(TIUY("LOC"),U,2)']""

               SET TIUY("LOC")=TIUY("LOC")_U_$PIECE($GET(^SC(+TIUY("LOC"),0)),U)

 +15       IF '$DATA(TIUY("DIV"))

               IF +$GET(TIUY("LOC"))

                   Begin DoDot:1

 +16                   NEW TIUDIV,DIC,DR,DA,DIQ,X,Y

 +17                   SET DIC=44

                       SET DIQ="TIUDIV"

                       SET DIQ(0)="IE"

                       SET DA=+TIUY("LOC")

                       SET DR="3.5"

                       DO EN^DIQ1

 +18                   IF '+$GET(TIUDIV(44,+DA,3.5,"I"))

                           QUIT 

 +19                   SET TIUY("DIV")=TIUDIV(44,+DA,3.5,"I")_U_TIUDIV(44,+DA,3.5,"E")

                   End DoDot:1

 +20       IF '$DATA(TIUY("DIV"))

               IF '+$GET(TIUY("LOC"))

                   Begin DoDot:1

 +21                   SET TIUY("DIV")=+$ORDER(^DG(40.8,"AD",+$GET(DUZ(2)),0))

 +22                   SET TIUY("DIV")=+TIUY("DIV")_U_$PIECE($GET(^DG(40.8,+$GET(TIUY("DIV")),0)),U)

                   End DoDot:1

 +23       SET TIUY("INS")=$GET(TIUY("DIV"))

 +24       SET TIUY("SC")=$GET(TIUY("SC"))

 +25       QUIT 

CURRENT(TIUY,DFN) ; Get current INPATIENT data

 +1        NEW VAIN

           DO INP^VADPT

 +2        SET TIUY("AD#")=$GET(VAIN(1))

           SET TIUY("PMD")=$GET(VAIN(2))

 +3        SET TIUY("TS")=$GET(VAIN(3))

           SET TIUY("WARD")=$GET(VAIN(4),"0^OUTPATIENT")

 +4        SET TIUY("RB")=$GET(VAIN(5))

 +5        IF +TIUY("WARD")

               Begin DoDot:1

 +6                NEW DIC,DIQ,DR,DA,TIUDIV,Y

 +7                SET DIC=42

                   SET DA=+TIUY("WARD")

                   SET DIQ="TIUDIV("

                   SET DIQ(0)="IE"

                   SET DR=".015;44"

 +8                DO EN^DIQ1

 +9                SET TIUY("DIV")=$GET(TIUDIV(42,DA,.015,"I"))_U_$GET(TIUDIV(42,DA,.015,"E"))

 +10               SET TIUY("LOC")=$GET(TIUDIV(42,DA,44,"I"))_U_$GET(TIUDIV(42,DA,44,"E"))

               End DoDot:1

 +11       SET TIUY("LOC")=$GET(TIUY("LOC"))

 +12       IF '+$GET(TIUY("DIV"))

               Begin DoDot:1

 +13               NEW DIC,DIQ,DR,DA

 +14               SET DIC=4

                   SET DR=".01"

                   SET DA=+$GET(DUZ(2))

                   SET DIQ="TIUDIV1"

 +15               DO EN^DIQ1

 +16      ;TIU*1*152 changed TIUDIV1(4,DUZ(2),.01) to $G(TIUDIV1(4,$G(DUZ(2)),.01)) ; TIU*1*200 Added + to 2nd piece and + to $G(DUZ(2))

 +17               SET TIUY("DIV")=+$GET(DUZ(2))_U_+$GET(TIUDIV1(4,+$GET(DUZ(2)),.01))

               End DoDot:1

 +18       QUIT