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