DGPMTSI ;ALB/LM - TREATING SPECIALTY INPATIENT INFO ; 6/15/93
;;5.3;Registration;**76**;Aug 13, 1993
;
START I $D(IO("Q")) S DGTSDT=ZTSAVE("DGTSDT"),PTLWD=ZTSAVE("PTLWD"),PTLTS=ZTSAVE("PTLTS"),PTCTS=ZTSAVE("PTCTS")
S (DGT,Y)=DGTSDT
X ^DD("DD") S DGTSDT=Y
F DFN=0:0 S DFN=$O(^DPT(DFN)) Q:'DFN S DGTS=0,DGXFR0="" D EN ; I DG1 D TREAT,START^DGPMTSI1,START^DGPMTSI2
D START^DGPMTSO
Q
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
K 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 F IAD=9999999.9999998-DGT:0 S IAD=$O(^DGPM("ATID1",DFN,IAD)) Q:'IAD S DGA1=$O(^DGPM("ATID1",DFN,IAD,0)) I DGA1]"" S DGCA=$G(^DGPM(DGA1,0)),DGDC=$G(^DGPM(+$P(DGCA,U,17),0)),DGTS=+$P(DGCA,U,9) D ; Q:DG1!($P(DGCA,U,18)'=40)
.I 'DGDC!(DGDC>DGT) D CA ; I $P(%,"^",18)=43!($P(%,"^",18)=45) S DG1="" Q ; -- set DG1="" if XFR is 43=to asih (other fac) or XFR is 45=change asih location (other fac)
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
;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) Q:$P(%,"^",18)=43 I MT=1!(MT=2) S DG1=$P(%,"^",6,7) D XFR:MT=2 Q:DG1
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) S:$P(%,"^",9)]"" DGS=$P(%,"^",9),DGTS=DGS S DGW=$P(%,"^",6) I MT=1!(MT=2) S DG1=$P(%,"^",6,7) D XFR:MT=2 Q:DG1
I DG1 D TREAT,START^DGPMTSI1,START^DGPMTSI2
I $P(DG1,"^",3)=13!($P(DG1,"^",3)=44) S 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))
S DGXFR0=%,DG1=DG1_"^"_$P(%,"^",18)
;I $P(%,"^",18)=13 S %=$O(^DGPM("APMV",DFN,DGA1,IMD)) I $D(^DGPM(+$O(^(%,0)),0)) S DGW=$P(^(0),"^",6)
I $P(%,"^",18)=13!($P(%,"^",18)=44) D
. N DGPMNI,DGPMTN,DGPMAB
. S DGPMNI=DGA1,DGPMTN=%
. D FINDLAST^DGPMV32 ; gets date/time which initiated ASIH (either to asih or to asih (other))
. S %=$O(^DGPM("APMV",DFN,DGA1,9999999.9999999-DGPMAB)) I $D(^DGPM(+$O(^(%,0)),0)) S DGW=$P(^(0),"^",6)
Q
;
TREAT 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 S TSXDT="" 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 $D(^DGPM(+DGDA,0)) S DGX=^(0) D TR2
Q
TR2 I +DGX<(DGT+.1)&(+DGX<+DG2) S DG2=DGS,DGTS=DGS I +$P(DGX,"^")>+$P(DGCA,"^") S Y=$P(DGX,"^") X ^DD("DD") S TSXDT=Y
I $P(DGX,"^",6)]"" S DGW=$P(DGX,"^",6)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMTSI 3149 printed Sep 23, 2025@20:25:47 Page 2
DGPMTSI ;ALB/LM - TREATING SPECIALTY INPATIENT INFO ; 6/15/93
+1 ;;5.3;Registration;**76**;Aug 13, 1993
+2 ;
START IF $DATA(IO("Q"))
SET DGTSDT=ZTSAVE("DGTSDT")
SET PTLWD=ZTSAVE("PTLWD")
SET PTLTS=ZTSAVE("PTLTS")
SET PTCTS=ZTSAVE("PTCTS")
+1 SET (DGT,Y)=DGTSDT
+2 XECUTE ^DD("DD")
SET DGTSDT=Y
+3 ; I DG1 D TREAT,START^DGPMTSI1,START^DGPMTSI2
FOR DFN=0:0
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
SET DGTS=0
SET DGXFR0=""
DO EN
+4 DO START^DGPMTSO
+5 QUIT
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
KILL 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
F ; Q:DG1!($P(DGCA,U,18)'=40)
FOR IAD=9999999.9999998-DGT:0
SET IAD=$ORDER(^DGPM("ATID1",DFN,IAD))
if 'IAD
QUIT
SET DGA1=$ORDER(^DGPM("ATID1",DFN,IAD,0))
IF DGA1]""
SET DGCA=$GET(^DGPM(DGA1,0))
SET DGDC=$GET(^DGPM(+$PIECE(DGCA,U,17),0))
SET DGTS=+$PIECE(DGCA,U,9)
Begin DoDot:1
+1 ; I $P(%,"^",18)=43!($P(%,"^",18)=45) S DG1="" Q ; -- set DG1="" if XFR is 43=to asih (other fac) or XFR is 45=change asih location (other fac)
IF 'DGDC!(DGDC>DGT)
DO CA
End DoDot:1
+2 KILL DGNO
QUIT
+3 ;
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 ;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) Q:$P(%,"^",18)=43 I MT=1!(MT=2) S DG1=$P(%,"^",6,7) D XFR:MT=2 Q:DG1
+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 $PIECE(%,"^",9)]""
SET DGS=$PIECE(%,"^",9)
SET DGTS=DGS
SET DGW=$PIECE(%,"^",6)
IF MT=1!(MT=2)
SET DG1=$PIECE(%,"^",6,7)
if MT=2
DO XFR
if DG1
QUIT
+5 IF DG1
DO TREAT
DO START^DGPMTSI1
DO START^DGPMTSI2
+6 IF $PIECE(DG1,"^",3)=13!($PIECE(DG1,"^",3)=44)
SET DG1=""
CAQ QUIT
+1 ;
XFR ; -- set DG1="" if XFR to asih(oth fac) --ELSE-- add MVT type to DG1
+1 ;S DGXFR0=%,DG1=$S($P(%,"^",18)=13:"",1:DG1_"^"_$P(%,"^",18))
+2 SET DGXFR0=%
SET DG1=DG1_"^"_$PIECE(%,"^",18)
+3 ;I $P(%,"^",18)=13 S %=$O(^DGPM("APMV",DFN,DGA1,IMD)) I $D(^DGPM(+$O(^(%,0)),0)) S DGW=$P(^(0),"^",6)
+4 IF $PIECE(%,"^",18)=13!($PIECE(%,"^",18)=44)
Begin DoDot:1
+5 NEW DGPMNI,DGPMTN,DGPMAB
+6 SET DGPMNI=DGA1
SET DGPMTN=%
+7 ; gets date/time which initiated ASIH (either to asih or to asih (other))
DO FINDLAST^DGPMV32
+8 SET %=$ORDER(^DGPM("APMV",DFN,DGA1,9999999.9999999-DGPMAB))
IF $DATA(^DGPM(+$ORDER(^(%,0)),0))
SET DGW=$PIECE(^(0),"^",6)
End DoDot:1
+9 QUIT
+10 ;
TREAT if 'DG1
QUIT
+1 SET DG2=9999999
DO TREAT1
+2 IF +DG2=9999999
SET DG2=0
QUIT
+3 SET DG2=$SELECT($DATA(^DIC(45.7,+DG2,0)):+$PIECE(^(0),U,2),1:0)
+4 QUIT
TREAT1 SET TSXDT=""
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 $DATA(^DGPM(+DGDA,0))
SET DGX=^(0)
DO TR2
+1 QUIT
TR2 IF +DGX<(DGT+.1)&(+DGX<+DG2)
SET DG2=DGS
SET DGTS=DGS
IF +$PIECE(DGX,"^")>+$PIECE(DGCA,"^")
SET Y=$PIECE(DGX,"^")
XECUTE ^DD("DD")
SET TSXDT=Y
+1 IF $PIECE(DGX,"^",6)]""
SET DGW=$PIECE(DGX,"^",6)
+2 QUIT
