- DGPMSTAT ;ALB/JDS - DETERMINE INPATIENT STATUS - FORMERLY DGINPW ;01 JAN 1986
- ;;5.3;Registration;**36,246**;Aug 13, 1993
- ;
- ; Note: This used to be named 'DGINPW'
- ; ------
- ;
- EN ; -- call to return coresp adm and mvt data of pt as of a date
- ; input: DFN => patient file ifn
- ; DGT => date to check if pt was inpatient
- ; output: DGA1 => coresp adm mvt ifn of ^DGPM
- ; DG1 => ward ^ room-bed ^ mvt type(for xfrs only)
- ; DGXFR0 => Oth of last xfr mvt for admission
- ; -- init
- N MT,IAD,IMD,DGCA,DGDC ; Inverse Adm Date & Inverse Mvt Date
- S DG1=""
- ;
- ; -- scan adms for pt
- ; -- if still inpt or d/c > DGT date then continue to CA
- ;F IAD=9999999.9999998-DGT:0 S IAD=$O(^DGPM("ATID1",DFN,IAD)) Q:'IAD S DGA1=+$O(^(IAD,0)) I $D(^DGPM(DGA1,0)),$S('$D(^DGPM(+$P(^(0),"^",17),0)):1,1:^(0)>DGT) D CA Q:DG1
- F IAD=9999999.9999998-DGT:0 S IAD=$O(^DGPM("ATID1",DFN,IAD)) Q:'IAD S DGA1=+$O(^(IAD,0)),DGCA=$G(^DGPM(DGA1,0)),DGDC=$G(^DGPM(+$P(DGCA,U,17),0)) D Q:DG1!($P(DGCA,U,18)'=40)
- .I 'DGDC!(DGDC>DGT) D CA I $P(%,U,18)=43!($P(%,U,18)=45) S DG1="" Q
- K DGNO Q
- ;
- CA ; -- scan mvts for cor. adm that happened on or before DGT date
- ; -- if mvt is adm or xfr then set DG1
- ; -- if mvt is xfr then continue to XFR
- S %=""
- F IMD=9999999.9999998-DGT:0 S IMD=$O(^DGPM("APMV",DFN,DGA1,IMD)) Q:'IMD I $D(^DGPM(+$O(^(IMD,0)),0)) S %=^(0),MT=$P(%,"^",2) I MT=1!(MT=2) S DG1=$P(%,"^",6,7) D XFR:MT=2 Q:DG1
- CAQ Q
- ;
- XFR ; -- set DG1="" if XFR to asih(oth fac) --ELSE-- add MVT type to DG1
- S DGXFR0=%,DG1=$S($P(%,"^",18)=13:"",1:DG1_"^"_$P(%,"^",18))
- Q
- ;
- TREAT S DG2=0 D EN:'$D(DG1) Q:'DG1 S DG2=9999999 D TREAT1
- I +DG2=9999999 S DG2=0 Q
- S DG2=$S($D(^DIC(45.7,+DG2,0)):+$P(^(0),U,2),1:0)
- Q
- TREAT1 F DGID=0:0 S DGID=$O(^DGPM("ATS",DFN,DGA1,DGID)) Q:'DGID F DGS=0:0 S DGS=$O(^DGPM("ATS",DFN,DGA1,DGID,DGS)) Q:'DGS F DGDA=0:0 S DGDA=$O(^DGPM("ATS",DFN,DGA1,DGID,DGS,DGDA)) Q:'DGDA I ^DGPM(+DGDA,0) S DGX=^(0) D TR2
- Q
- TR2 I +DGX<(DGT+.1)&(+DGX<+DG2) S DG2=DGS
- Q
- DGT(X) ; FIGURE OUT WHICH TYPE OF DATE TO USE FOR DGWARDWHEN
- ; Input: X=Date in either FM format or regular date
- ; Output: Date in FM format
- N Y,%DT
- I '$D(X) S X=DT G DGTQ
- S %DT="T" D ^%DT S X=Y
- DGTQ Q X
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMSTAT 2311 printed Feb 19, 2025@00:15:55 Page 2
- DGPMSTAT ;ALB/JDS - DETERMINE INPATIENT STATUS - FORMERLY DGINPW ;01 JAN 1986
- +1 ;;5.3;Registration;**36,246**;Aug 13, 1993
- +2 ;
- +3 ; Note: This used to be named 'DGINPW'
- +4 ; ------
- +5 ;
- EN ; -- call to return coresp adm and mvt data of pt as of a date
- +1 ; input: DFN => patient file ifn
- +2 ; DGT => date to check if pt was inpatient
- +3 ; output: DGA1 => coresp adm mvt ifn of ^DGPM
- +4 ; DG1 => ward ^ room-bed ^ mvt type(for xfrs only)
- +5 ; DGXFR0 => Oth of last xfr mvt for admission
- +6 ; -- init
- +7 ; Inverse Adm Date & Inverse Mvt Date
- NEW MT,IAD,IMD,DGCA,DGDC
- +8 SET DG1=""
- +9 ;
- +10 ; -- scan adms for pt
- +11 ; -- if still inpt or d/c > DGT date then continue to CA
- +12 ;F IAD=9999999.9999998-DGT:0 S IAD=$O(^DGPM("ATID1",DFN,IAD)) Q:'IAD S DGA1=+$O(^(IAD,0)) I $D(^DGPM(DGA1,0)),$S('$D(^DGPM(+$P(^(0),"^",17),0)):1,1:^(0)>DGT) D CA Q:DG1
- +13 FOR IAD=9999999.9999998-DGT:0
- SET IAD=$ORDER(^DGPM("ATID1",DFN,IAD))
- if 'IAD
- QUIT
- SET DGA1=+$ORDER(^(IAD,0))
- SET DGCA=$GET(^DGPM(DGA1,0))
- SET DGDC=$GET(^DGPM(+$PIECE(DGCA,U,17),0))
- Begin DoDot:1
- +14 IF 'DGDC!(DGDC>DGT)
- DO CA
- IF $PIECE(%,U,18)=43!($PIECE(%,U,18)=45)
- SET DG1=""
- QUIT
- End DoDot:1
- if DG1!($PIECE(DGCA,U,18)'=40)
- QUIT
- +15 KILL DGNO
- QUIT
- +16 ;
- CA ; -- scan mvts for cor. adm that happened on or before DGT date
- +1 ; -- if mvt is adm or xfr then set DG1
- +2 ; -- if mvt is xfr then continue to XFR
- +3 SET %=""
- +4 FOR IMD=9999999.9999998-DGT:0
- SET IMD=$ORDER(^DGPM("APMV",DFN,DGA1,IMD))
- if 'IMD
- QUIT
- IF $DATA(^DGPM(+$ORDER(^(IMD,0)),0))
- SET %=^(0)
- SET MT=$PIECE(%,"^",2)
- IF MT=1!(MT=2)
- SET DG1=$PIECE(%,"^",6,7)
- if MT=2
- DO XFR
- if DG1
- QUIT
- CAQ QUIT
- +1 ;
- XFR ; -- set DG1="" if XFR to asih(oth fac) --ELSE-- add MVT type to DG1
- +1 SET DGXFR0=%
- SET DG1=$SELECT($PIECE(%,"^",18)=13:"",1:DG1_"^"_$PIECE(%,"^",18))
- +2 QUIT
- +3 ;
- TREAT SET DG2=0
- if '$DATA(DG1)
- DO EN
- if 'DG1
- QUIT
- SET DG2=9999999
- DO TREAT1
- +1 IF +DG2=9999999
- SET DG2=0
- QUIT
- +2 SET DG2=$SELECT($DATA(^DIC(45.7,+DG2,0)):+$PIECE(^(0),U,2),1:0)
- +3 QUIT
- TREAT1 FOR DGID=0:0
- SET DGID=$ORDER(^DGPM("ATS",DFN,DGA1,DGID))
- if 'DGID
- QUIT
- FOR DGS=0:0
- SET DGS=$ORDER(^DGPM("ATS",DFN,DGA1,DGID,DGS))
- if 'DGS
- QUIT
- FOR DGDA=0:0
- SET DGDA=$ORDER(^DGPM("ATS",DFN,DGA1,DGID,DGS,DGDA))
- if 'DGDA
- QUIT
- IF ^DGPM(+DGDA,0)
- SET DGX=^(0)
- DO TR2
- +1 QUIT
- TR2 IF +DGX<(DGT+.1)&(+DGX<+DG2)
- SET DG2=DGS
- +1 QUIT
- DGT(X) ; FIGURE OUT WHICH TYPE OF DATE TO USE FOR DGWARDWHEN
- +1 ; Input: X=Date in either FM format or regular date
- +2 ; Output: Date in FM format
- +3 NEW Y,%DT
- +4 IF '$DATA(X)
- SET X=DT
- GOTO DGTQ
- +5 SET %DT="T"
- DO ^%DT
- SET X=Y
- DGTQ QUIT X