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 Apr 09, 2024@21:49:41 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
