VADPT30 ;ALB/MJK - Current Inpatient Variables; 12 DEC 1988 ; 5/5/05 11:41am
;;5.3;Registration;**111,498,509,662**;Aug 13, 1993
;
VAR ; -- inpatient demographics variables
; input: DFN, VATD = inverse date ; VACN =
; VAPRC = ; VAPRT =
;
; output: VAWD = ward ; VATS = tr. spec. ; VARM = room/bed
; VAPP = doc ; VADX = diagnosis ; VAMV = mv entry
; VAAP = attending physician
; VAFD = answer to facility directory question
;
S (VAWDA,VAWD,VATS,VAMV,VARM,VAPP,VAAP,VADX,VAFD)="",VAID=VATD
; -- get mv
D MV G VARQ:VAMV0']""
S Y=$G(^DGPM(+$P(VAMV0,"^",14),0)) I $P(Y,"^",2)=1 D
.N DCD
.S DCD=+$P(Y,"^",17) I DCD S DCD=+$G(^DGPM(DCD,0))
.S Y=$G(^DGPM(+$P(VAMV0,"^",14),"DIR"))
.S Y=$P(Y,"^",1)
.I Y="" S Y=$S('DCD:1,(DCD<3030414.999999):"",1:1) Q:Y=""
.S VAFD=Y_"^"_$$EXTERNAL^DILFD(405,41,,Y)
; quit if not an adm or xfr
I "^1^2^"'[("^"_$P(VAMV0,"^",2)_"^") G VARQ
I 'VAPRC,"^2^3^13^25^26^43^44^45^"[("^"_VAMT_"^") G VARQ
I VAPRC,"^13^43^44^45^"[("^"_VAMT_"^") G VARQ
S:VAPRC VABO=$S(VAMT<4:VAMT,1:4) D GET
;I 'VACN,'VATS S VATS=TSD ;what is this
VARQ K VAMV0,VAMT,VAID
Q
;
GET ; -- get variables and quit when all set(Y=1)
S VACA=+$P(VAMV0,"^",14)
N VAT
D TS,SET G GETQ:Y
F VAID=VATD:0 S VAID=$O(^DGPM("APMV",DFN,VACA,VAID)) Q:'VAID F VAIFN=0:0 S VAIFN=$O(^DGPM("APMV",DFN,VACA,VAID,VAIFN)) Q:'VAIFN I $D(^DGPM(VAIFN,0)) S VAMV0=^(0) D SET G GETQ:Y
GETQ K VACA,VAIFN,VAID Q
;
KVAR K VAMV,VAWDA,VAWD,VARM,VAPP,VAAP,VATS,VATD,VAPRC,VAPRT,VACN,VADX,VABO,VAFD Q
;
SET ; -- set variables if null
S Y=0
I 'VAWD,$D(^DIC(42,+$P(VAMV0,"^",6),0)) S VAWDA=$S($D(VAIFN):VAIFN,1:VAMV),VAWD=$P(VAMV0,"^",6)_"^"_$P(^(0),"^") S VARM="" I $D(^DG(405.4,+$P(VAMV0,"^",7),0)) S VARM=$P(VAMV0,"^",7)_"^"_$P(^(0),"^")
I 'VACN,VAWD S Y=1
N VARSTR
S VARSTR="^^^^^VAWD^VARM^VAPP^VATS^VADX^^^^^^^^^VAAP^"
S $P(VARSTR,"^",41)="VAFD"
I VACN,'VAPRT,$D(DGPMDDF),@$P(VARSTR,"^",+DGPMDDF),VAMV S Y=1
I VACN,VAPRT,VAWD,VAMV,VADX]"" S Y=1
Q
;
TS ; set VADX, VATS, VAAP, and VAPP via VACA x-refs
N VAMV0
S:$D(^DGPM(VACA,0)) VADX=$P(^(0),"^",10)
F VAID=VATD:0 S VAID=$O(^DGPM("ATS",DFN,VACA,VAID)) Q:'VAID F VAT=0:0 S VAT=$O(^DGPM("ATS",DFN,VACA,VAID,VAT)) Q:'VAT F VAIFN=0:0 S VAIFN=$O(^DGPM("ATS",DFN,VACA,VAID,VAT,VAIFN)) Q:'VAIFN D TS1 G TSQ:VAPP&VATS&VAAP
TSQ K VAIFN,VAT Q
;
TS1 ; set VATS, VAPP, and VAAP
Q:'$D(^DGPM(VAIFN,0)) S VAMV0=^(0)
I 'VAPP,$D(^VA(200,+$P(VAMV0,"^",8),0)) S Y=$P(VAMV0,"^",8)_"^"_$P(^(0),"^") S VAPP=Y
I 'VAAP,$D(^VA(200,+$P(VAMV0,"^",19),0)) S Y=$P(VAMV0,"^",19)_"^"_$P(^(0),"^") S VAAP=Y
I 'VATS,$D(^DIC(45.7,+$P(VAMV0,"^",9),0)) S VATS=$P(VAMV0,"^",9)_"^"_$P(^(0),"^")
Q
;
MV ; -- get latest mv for pt before VAID and not ASIH mv
S (VAMV,VAMV0)=""
F VAID=VAID:0 S VAID=$O(^DGPM("APID",DFN,VAID)) G MVQ:'VAID S VAMV=$O(^DGPM("APID",DFN,VAID,0)) I $D(^DGPM(+VAMV,0)) S VAMT=$P(^(0),"^",18) G MVQ:'VAMT Q:"^13^41^42^47^"'[("^"_VAMT_"^")
S VAMV0=^DGPM(VAMV,0)
MVQ Q
;
A ;return current admission or last admission for patient
S Y=$S($D(^DPT(DFN,.105)):+^(.105),1:0) G AQ:$D(^DGPM(Y,0))
N VAID,VAMV,VAMV0
F VAID=0:0 S VAID=$O(^DGPM("ATID1",DFN,VAID)) Q:'VAID F VAMV=0:0 S VAMV=$O(^DGPM("ATID1",DFN,VAID,VAMV)) Q:'VAMV I $D(^DGPM(VAMV,0)) S VAMV0=^(0) D DIS G AQ:Y
S Y=0
AQ Q
;
DIS ; check for ASIH discharges
S Y=$S('$D(^DGPM(+$P(VAMV0,"^",17),0)):VAMV,"^41^46"[(U_$P(^(0),"^",18)_U):0,1:VAMV)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVADPT30 3498 printed Sep 23, 2025@20:37:09 Page 2
VADPT30 ;ALB/MJK - Current Inpatient Variables; 12 DEC 1988 ; 5/5/05 11:41am
+1 ;;5.3;Registration;**111,498,509,662**;Aug 13, 1993
+2 ;
VAR ; -- inpatient demographics variables
+1 ; input: DFN, VATD = inverse date ; VACN =
+2 ; VAPRC = ; VAPRT =
+3 ;
+4 ; output: VAWD = ward ; VATS = tr. spec. ; VARM = room/bed
+5 ; VAPP = doc ; VADX = diagnosis ; VAMV = mv entry
+6 ; VAAP = attending physician
+7 ; VAFD = answer to facility directory question
+8 ;
+9 SET (VAWDA,VAWD,VATS,VAMV,VARM,VAPP,VAAP,VADX,VAFD)=""
SET VAID=VATD
+10 ; -- get mv
+11 DO MV
if VAMV0']""
GOTO VARQ
+12 SET Y=$GET(^DGPM(+$PIECE(VAMV0,"^",14),0))
IF $PIECE(Y,"^",2)=1
Begin DoDot:1
+13 NEW DCD
+14 SET DCD=+$PIECE(Y,"^",17)
IF DCD
SET DCD=+$GET(^DGPM(DCD,0))
+15 SET Y=$GET(^DGPM(+$PIECE(VAMV0,"^",14),"DIR"))
+16 SET Y=$PIECE(Y,"^",1)
+17 IF Y=""
SET Y=$SELECT('DCD:1,(DCD<3030414.999999):"",1:1)
if Y=""
QUIT
+18 SET VAFD=Y_"^"_$$EXTERNAL^DILFD(405,41,,Y)
End DoDot:1
+19 ; quit if not an adm or xfr
+20 IF "^1^2^"'[("^"_$PIECE(VAMV0,"^",2)_"^")
GOTO VARQ
+21 IF 'VAPRC
IF "^2^3^13^25^26^43^44^45^"[("^"_VAMT_"^")
GOTO VARQ
+22 IF VAPRC
IF "^13^43^44^45^"[("^"_VAMT_"^")
GOTO VARQ
+23 if VAPRC
SET VABO=$SELECT(VAMT<4:VAMT,1:4)
DO GET
+24 ;I 'VACN,'VATS S VATS=TSD ;what is this
VARQ KILL VAMV0,VAMT,VAID
+1 QUIT
+2 ;
GET ; -- get variables and quit when all set(Y=1)
+1 SET VACA=+$PIECE(VAMV0,"^",14)
+2 NEW VAT
+3 DO TS
DO SET
if Y
GOTO GETQ
+4 FOR VAID=VATD:0
SET VAID=$ORDER(^DGPM("APMV",DFN,VACA,VAID))
if 'VAID
QUIT
FOR VAIFN=0:0
SET VAIFN=$ORDER(^DGPM("APMV",DFN,VACA,VAID,VAIFN))
if 'VAIFN
QUIT
IF $DATA(^DGPM(VAIFN,0))
SET VAMV0=^(0)
DO SET
if Y
GOTO GETQ
GETQ KILL VACA,VAIFN,VAID
QUIT
+1 ;
KVAR KILL VAMV,VAWDA,VAWD,VARM,VAPP,VAAP,VATS,VATD,VAPRC,VAPRT,VACN,VADX,VABO,VAFD
QUIT
+1 ;
SET ; -- set variables if null
+1 SET Y=0
+2 IF 'VAWD
IF $DATA(^DIC(42,+$PIECE(VAMV0,"^",6),0))
SET VAWDA=$SELECT($DATA(VAIFN):VAIFN,1:VAMV)
SET VAWD=$PIECE(VAMV0,"^",6)_"^"_$PIECE(^(0),"^")
SET VARM=""
IF $DATA(^DG(405.4,+$PIECE(VAMV0,"^",7),0))
SET VARM=$PIECE(VAMV0,"^",7)_"^"_$PIECE(^(0),"^")
+3 IF 'VACN
IF VAWD
SET Y=1
+4 NEW VARSTR
+5 SET VARSTR="^^^^^VAWD^VARM^VAPP^VATS^VADX^^^^^^^^^VAAP^"
+6 SET $PIECE(VARSTR,"^",41)="VAFD"
+7 IF VACN
IF 'VAPRT
IF $DATA(DGPMDDF)
IF @$PIECE(VARSTR,"^",+DGPMDDF)
IF VAMV
SET Y=1
+8 IF VACN
IF VAPRT
IF VAWD
IF VAMV
IF VADX]""
SET Y=1
+9 QUIT
+10 ;
TS ; set VADX, VATS, VAAP, and VAPP via VACA x-refs
+1 NEW VAMV0
+2 if $DATA(^DGPM(VACA,0))
SET VADX=$PIECE(^(0),"^",10)
+3 FOR VAID=VATD:0
SET VAID=$ORDER(^DGPM("ATS",DFN,VACA,VAID))
if 'VAID
QUIT
FOR VAT=0:0
SET VAT=$ORDER(^DGPM("ATS",DFN,VACA,VAID,VAT))
if 'VAT
QUIT
FOR VAIFN=0:0
SET VAIFN=$ORDER(^DGPM("ATS",DFN,VACA,VAID,VAT,VAIFN))
if 'VAIFN
QUIT
DO TS1
if VAPP&VATS&VAAP
GOTO TSQ
TSQ KILL VAIFN,VAT
QUIT
+1 ;
TS1 ; set VATS, VAPP, and VAAP
+1 if '$DATA(^DGPM(VAIFN,0))
QUIT
SET VAMV0=^(0)
+2 IF 'VAPP
IF $DATA(^VA(200,+$PIECE(VAMV0,"^",8),0))
SET Y=$PIECE(VAMV0,"^",8)_"^"_$PIECE(^(0),"^")
SET VAPP=Y
+3 IF 'VAAP
IF $DATA(^VA(200,+$PIECE(VAMV0,"^",19),0))
SET Y=$PIECE(VAMV0,"^",19)_"^"_$PIECE(^(0),"^")
SET VAAP=Y
+4 IF 'VATS
IF $DATA(^DIC(45.7,+$PIECE(VAMV0,"^",9),0))
SET VATS=$PIECE(VAMV0,"^",9)_"^"_$PIECE(^(0),"^")
+5 QUIT
+6 ;
MV ; -- get latest mv for pt before VAID and not ASIH mv
+1 SET (VAMV,VAMV0)=""
+2 FOR VAID=VAID:0
SET VAID=$ORDER(^DGPM("APID",DFN,VAID))
if 'VAID
GOTO MVQ
SET VAMV=$ORDER(^DGPM("APID",DFN,VAID,0))
IF $DATA(^DGPM(+VAMV,0))
SET VAMT=$PIECE(^(0),"^",18)
if 'VAMT
GOTO MVQ
if "^13^41^42^47^"'[("^"_VAMT_"^")
QUIT
+3 SET VAMV0=^DGPM(VAMV,0)
MVQ QUIT
+1 ;
A ;return current admission or last admission for patient
+1 SET Y=$SELECT($DATA(^DPT(DFN,.105)):+^(.105),1:0)
if $DATA(^DGPM(Y,0))
GOTO AQ
+2 NEW VAID,VAMV,VAMV0
+3 FOR VAID=0:0
SET VAID=$ORDER(^DGPM("ATID1",DFN,VAID))
if 'VAID
QUIT
FOR VAMV=0:0
SET VAMV=$ORDER(^DGPM("ATID1",DFN,VAID,VAMV))
if 'VAMV
QUIT
IF $DATA(^DGPM(VAMV,0))
SET VAMV0=^(0)
DO DIS
if Y
GOTO AQ
+4 SET Y=0
AQ QUIT
+1 ;
DIS ; check for ASIH discharges
+1 SET Y=$SELECT('$DATA(^DGPM(+$PIECE(VAMV0,"^",17),0)):VAMV,"^41^46"[(U_$PIECE(^(0),"^",18)_U):0,1:VAMV)
+2 QUIT
+3 ;
