- VADPT2 ;ALB/MJK - ESTABLISH PATIENT VARIABLES ; 3/23/88 9:13 PM ;
- ;;5.3;PIMS;**69,1004,1015,1016**;JUN 30, 2012;Build 20
- 5 ; -- INP call
- S (VAWD,VATS,VADX,VAPP,VAAP,VARM)="" S VANOW=$$NOW^XLFDT K VAMV,VAMV0
- I '$D(VAINDT) N VAINDT S VAINDT=VANOW
- S VATD=9999999.999999-VAINDT
- F VAID=VATD:0 S VAID=$O(^DGPM("APID",DFN,VAID)) Q:'VAID S VAMV=$O(^(VAID,0)) D CHK I $D(VAMV) K:"^3^4^5^"[("^"_VAMT_"^") VAMV,VAMV0 Q
- ;
- G:'$D(VAMV0) DONE
- S (VAPRT,VAPRC,VACN)=1 D GET^VADPT30
- S VAMV0=^DGPM(VAMV,0),VAMVT=$P(VAMV0,"^",4),VACA=$P(VAMV0,"^",14),VACA0=$S($D(^DGPM(+VACA,0)):^(0),1:"")
- ;
- ; set: adm ifn(1) ; doctor(2) ; tr spec(3) ; ward(4) ; room(5) ; attending (11)
- S @VAV@($P(VAS,"^",1))=VACA,@VAV@($P(VAS,"^",2))=VAPP,@VAV@($P(VAS,"^",3))=VATS,@VAV@($P(VAS,"^",4))=VAWD,@VAV@($P(VAS,"^",5))=$P(VARM,"^",2),@VAV@($P(VAS,"^",11))=VAAP
- ;
- ; set bed/no bed mvt type(6)
- D IB S @VAV@($P(VAS,"^",6))=VAZ
- ;
- ; set adm date(7)
- S Y=+VACA0 X:Y ^DD("DD") S @VAV@($P(VAS,"^",7))=+VACA0_"^"_Y
- ;
- ; set: adm type(8) ; adm dx(9) ; ptf ifn(10)
- S @VAV@($P(VAS,"^",8))=$P(VACA0,"^",4)_"^"_$S($D(^DG(405.1,+$P(VACA0,"^",4),0)):$P(^(0),"^"),1:""),@VAV@($P(VAS,"^",9))=$P(VACA0,"^",10),@VAV@($P(VAS,"^",10))=$P(VACA0,"^",16)
- ;
- DONE K VAID,VANOW,VACA,VACA0,VAMV,VAMV0,VATD,VAMT,VAMVT D KVAR^VADPT30 Q
- ;
- IB ;In-Bed status
- ; input: VAINDT = internal date of requested info
- ; VAMV = starting IFN
- ; VAMV0 = 0th of VAMV
- ;
- ; output: VAZ = <O:not in bed OR 1: in bed>^fac. mvt name
- ; VAZ(2) = abs ret date
- ;
- S VAZ=0,VAZ(2)=""
- S VAXI=+$O(^DGPM("APMV",DFN,+$P(VAMV0,"^",14),9999999.999999-VAINDT)),VAXI=+$O(^(VAXI,0))
- I 'VAXI,$D(VAIP("L")),$P(VAMV0,"^",2)=4 S VAXI=VAMV ; only used via IN5
- G IBQ:'VAXI
- S VAX0=$S($D(^DGPM(VAXI,0)):^(0),1:"")
- G IBQ:VAX0']"",IBQ:"^3^5^"[("^"_$P(VAX0,"^",2)_"^")
- S VAXI=$S($D(^DG(405.1,+$P(VAX0,"^",4),0)):$P(^(0),"^"),1:"")
- ; -- check in-bed status flag
- S VAZ=$S('$D(^DG(405.2,+$P(VAX0,"^",18),"E")):1,1:'^("E"))_"^"_VAXI,VAZ(2)=$P(VAX0,"^",13)
- IBQ K VAXI,VAX0 Q
- ;
- CHK ; -- check if mvt exists and if 'while asih' type d/c
- ; if VAMV returned undefined then continue $Oing
- ;
- I $D(^DGPM(+VAMV,0)) S VAMV0=^(0),VAMT=$P(VAMV0,"^",2)
- I '$D(VAMV0) K VAMV G CHKQ
- I "^42^47^"[("^"_$P(VAMV0,"^",18)_"^"),$P(VAMV0,"^",22)'=2,$O(^DGPM("APMV",DFN,+$P(VAMV0,"^",14),VAID)),$O(^($O(^(VAID)),0)),$D(^DGPM($O(^(0)),0)),"^13^44^"[("^"_$P(^(0),"^",18)_"^") K VAMV,VAMV0
- ; info: 47 mvt can not have seq #; will always be null
- CHKQ Q
- ;
- ADM ; -- send back adm ifn for dfn on vaindt or now
- S VADT=$S($D(VAINDT):VAINDT,1:"") I 'VADT S VADT=$$NOW^XLFDT
- S VAID=9999999.999999-VADT,VADMVT=""
- F S VAID=$O(^DGPM("ATID1",DFN,VAID)) Q:'VAID S VAMV=+$O(^DGPM("ATID1",DFN,VAID,0)) I $D(^DGPM(VAMV,0)) S VAMV0=^(0),VAMV1=$S($D(^DGPM(+$P(VAMV0,"^",17),0)):^(0),1:9999999.999999) D Q:VADMVT!($P(VAMV0,U,18)'=40)
- .I VAMV0'>VADT,VAMV1>VADT S VADMVT=VAMV
- K VAID,VADT,VAMV,VAMV0,VAMV1
- VADPT2 ;ALB/MJK - ESTABLISH PATIENT VARIABLES ; 3/23/88 9:13 PM ;
- +1 ;;5.3;PIMS;**69,1004,1015,1016**;JUN 30, 2012;Build 20
- 5 ; -- INP call
- +1 SET (VAWD,VATS,VADX,VAPP,VAAP,VARM)=""
- SET VANOW=$$NOW^XLFDT
- KILL VAMV,VAMV0
- +2 IF '$DATA(VAINDT)
- NEW VAINDT
- SET VAINDT=VANOW
- +3 SET VATD=9999999.999999-VAINDT
- +4 FOR VAID=VATD:0
- SET VAID=$ORDER(^DGPM("APID",DFN,VAID))
- IF 'VAID
- QUIT
- SET VAMV=$ORDER(^(VAID,0))
- DO CHK
- IF $DATA(VAMV)
- IF "^3^4^5^"[("^"_VAMT_"^")
- KILL VAMV,VAMV0
- QUIT
- +5 ;
- +6 IF '$DATA(VAMV0)
- GOTO DONE
- +7 SET (VAPRT,VAPRC,VACN)=1
- DO GET^VADPT30
- +8 SET VAMV0=^DGPM(VAMV,0)
- SET VAMVT=$PIECE(VAMV0,"^",4)
- SET VACA=$PIECE(VAMV0,"^",14)
- SET VACA0=$SELECT($DATA(^DGPM(+VACA,0)):^(0),1:"")
- +9 ;
- +10 ; set: adm ifn(1) ; doctor(2) ; tr spec(3) ; ward(4) ; room(5) ; attending (11)
- +11 SET @VAV@($PIECE(VAS,"^",1))=VACA
- SET @VAV@($PIECE(VAS,"^",2))=VAPP
- SET @VAV@($PIECE(VAS,"^",3))=VATS
- SET @VAV@($PIECE(VAS,"^",4))=VAWD
- SET @VAV@($PIECE(VAS,"^",5))=$PIECE(VARM,"^",2)
- SET @VAV@($PIECE(VAS,"^",11))=VAAP
- +12 ;
- +13 ; set bed/no bed mvt type(6)
- +14 DO IB
- SET @VAV@($PIECE(VAS,"^",6))=VAZ
- +15 ;
- +16 ; set adm date(7)
- +17 SET Y=+VACA0
- IF Y
- XECUTE ^DD("DD")
- SET @VAV@($PIECE(VAS,"^",7))=+VACA0_"^"_Y
- +18 ;
- +19 ; set: adm type(8) ; adm dx(9) ; ptf ifn(10)
- +20 SET @VAV@($PIECE(VAS,"^",8))=$PIECE(VACA0,"^",4)_"^"_$SELECT($DATA(^DG(405.1,+$PIECE(VACA0,"^",4),0)):$PIECE(^(0),"^"),1:"")
- SET @VAV@($PIECE(VAS,"^",9))=$PIECE(VACA0,"^",10)
- SET @VAV@($PIECE(VAS,"^",10))=$PIECE(VACA0,"^",16)
- +21 ;
- DONE KILL VAID,VANOW,VACA,VACA0,VAMV,VAMV0,VATD,VAMT,VAMVT
- DO KVAR^VADPT30
- QUIT
- +1 ;
- IB ;In-Bed status
- +1 ; input: VAINDT = internal date of requested info
- +2 ; VAMV = starting IFN
- +3 ; VAMV0 = 0th of VAMV
- +4 ;
- +5 ; output: VAZ = <O:not in bed OR 1: in bed>^fac. mvt name
- +6 ; VAZ(2) = abs ret date
- +7 ;
- +8 SET VAZ=0
- SET VAZ(2)=""
- +9 SET VAXI=+$ORDER(^DGPM("APMV",DFN,+$PIECE(VAMV0,"^",14),9999999.999999-VAINDT))
- SET VAXI=+$ORDER(^(VAXI,0))
- +10 ; only used via IN5
- IF 'VAXI
- IF $DATA(VAIP("L"))
- IF $PIECE(VAMV0,"^",2)=4
- SET VAXI=VAMV
- +11 IF 'VAXI
- GOTO IBQ
- +12 SET VAX0=$SELECT($DATA(^DGPM(VAXI,0)):^(0),1:"")
- +13 IF VAX0']""
- GOTO IBQ
- IF "^3^5^"[("^"_$PIECE(VAX0,"^",2)_"^")
- GOTO IBQ
- +14 SET VAXI=$SELECT($DATA(^DG(405.1,+$PIECE(VAX0,"^",4),0)):$PIECE(^(0),"^"),1:"")
- +15 ; -- check in-bed status flag
- +16 SET VAZ=$SELECT('$DATA(^DG(405.2,+$PIECE(VAX0,"^",18),"E")):1,1:'^("E"))_"^"_VAXI
- SET VAZ(2)=$PIECE(VAX0,"^",13)
- IBQ KILL VAXI,VAX0
- QUIT
- +1 ;
- CHK ; -- check if mvt exists and if 'while asih' type d/c
- +1 ; if VAMV returned undefined then continue $Oing
- +2 ;
- +3 IF $DATA(^DGPM(+VAMV,0))
- SET VAMV0=^(0)
- SET VAMT=$PIECE(VAMV0,"^",2)
- +4 IF '$DATA(VAMV0)
- KILL VAMV
- GOTO CHKQ
- +5 IF "^42^47^"[("^"_$PIECE(VAMV0,"^",18)_"^")
- IF $PIECE(VAMV0,"^",22)'=2
- IF $ORDER(^DGPM("APMV",DFN,+$PIECE(VAMV0,"^",14),VAID))
- IF $ORDER(^($ORDER(^(VAID)),0))
- IF $DATA(^DGPM($ORDER(^(0)),0))
- IF "^13^44^"[("^"_$PIECE(^(0),"^",18)_"^")
- KILL VAMV,VAMV0
- +6 ; info: 47 mvt can not have seq #; will always be null
- CHKQ QUIT
- +1 ;
- ADM ; -- send back adm ifn for dfn on vaindt or now
- +1 SET VADT=$SELECT($DATA(VAINDT):VAINDT,1:"")
- IF 'VADT
- SET VADT=$$NOW^XLFDT
- +2 SET VAID=9999999.999999-VADT
- SET VADMVT=""
- +3 FOR
- SET VAID=$ORDER(^DGPM("ATID1",DFN,VAID))
- IF 'VAID
- QUIT
- SET VAMV=+$ORDER(^DGPM("ATID1",DFN,VAID,0))
- IF $DATA(^DGPM(VAMV,0))
- SET VAMV0=^(0)
- SET VAMV1=$SELECT($DATA(^DGPM(+$PIECE(VAMV0,"^",17),0)):^(0),1:9999999.999999)
- Begin DoDot:1
- +4 IF VAMV0'>VADT
- IF VAMV1>VADT
- SET VADMVT=VAMV
- End DoDot:1
- IF VADMVT!($PIECE(VAMV0,U,18)'=40)
- QUIT
- +5 KILL VAID,VADT,VAMV,VAMV0,VAMV1
