- DGPMTSI ;ALB/LM - TREATING SPECIALTY INPATIENT INFO ; 6/15/93
- ;;5.3;Registration;**76,1015**;Aug 13, 1993;Build 21
- ;
- 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
- DGPMTSI ;ALB/LM - TREATING SPECIALTY INPATIENT INFO ; 6/15/93
- +1 ;;5.3;Registration;**76,1015**;Aug 13, 1993;Build 21
- +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
