MMRSCRE2 ;TCK - Print CRE Report Cont. (Contains functions to collect patient movements) ; 3/3/17 10:37am
;;1.0;MDRO PROGRAM TOOLS;**4,5**;Jun 01, 2016;Build 146
;
GETMOVE ;Collects ward movements for patients that were admitted or discharged in date range.
N DUPLOC,MMRSLOC2
D GETADM(LOC)
;
GETADM(LOC) ;
N TT,MOVDT,MOVIFN,TRANTYPE,INWARD,INDATE,INIFN,INTT,OUTDATE,OUTIFN,OUTTT,NEXTIEN,LOCNAME,VAIP,INLOC
N OUTWARD,PREVWARD
F TT=1,2 S MOVDT=STRTDT-.0000001 F S MOVDT=$O(^DGPM("ATT"_TT,MOVDT)) Q:(MOVDT>ENDDT)!('MOVDT) D
.S MOVIFN="" F S MOVIFN=$O(^DGPM("ATT"_TT,MOVDT,MOVIFN)) Q:'MOVIFN D
..D KVA^VADPT S DFN=$P($G(^DGPM(MOVIFN,0)),"^",3),VAIP("E")=MOVIFN D IN5^VADPT
..S TRANTYPE=$$TRANTYPE(+VAIP(4),+VAIP(2),VAIP(1),DFN)
..S PREVWARD=$P(TRANTYPE,U,2)
..I PREVWARD="" S PREVWARD=+VAIP(15,4)
..S TRANTYPE=$P(TRANTYPE,U,1)
..I TRANTYPE<1!(TRANTYPE=3) Q
..S INWARD=+VAIP(5),WARD=$$GET1^DIQ(42,INWARD,.01,"E")
..I $G(INWARD)>0 D
...S HSPLC=$$GET1^DIQ(42,INWARD,44,"I")
...S DIV=$$GET1^DIQ(44,HSPLC,3.5,"E")
...S DIVS=$$GET1^DIQ(44,HSPLC,3.5,"I")
...S DIVID=$$GET1^DIQ(40.8,DIVS,1,"I"),LOC=$$GET1^DIQ(40.8,DIVS,.01,"I")
..;IS THIS WARD EXCLUDED FROM THIS REPORT
..Q:DIV'=LOC
..S LOCNAME=LOC
..S WRDLOC(INWARD)=""
..I TRANTYPE=2,'$$CNGWARD(LOC,PREVWARD,INWARD) Q
..;SET GLOBAL
..S INDATE=+VAIP(3)
..S INIFN=MOVIFN
..S INTT=TRANTYPE
..S ADT=$$GET1^DIQ(405,MOVIFN,.04,"E")
..S (OUTDATE,OUTIFN,OUTTT)=""
..F Q:(VAIP(16)="")!(OUTIFN) D
...S TRANTYPE=$$TRANTYPE(+VAIP(16,3),+VAIP(16,2),VAIP(16),DFN)
...S OUTWARD=$P(TRANTYPE,U,2)
...S NEXTIEN=$P(TRANTYPE,U,3)
...S TRANTYPE=$P(TRANTYPE,U,1)
...I OUTWARD="" S OUTWARD=+VAIP(16,4)
...I TRANTYPE=3 S OUTDATE=+VAIP(16,1),OUTIFN=VAIP(16),OUTTT=3
...;I TRANTYPE=2,$$CNGWARD(LOC,INWARD,OUTWARD) S OUTDATE=+VAIP(16,1),OUTIFN=VAIP(16),OUTTT=2
...Q:OUTIFN
...I NEXTIEN="" S NEXTIEN=VAIP(16)
...D KVA^VADPT
...S VAIP("E")=NEXTIEN
...D IN5^VADPT
..S INLOC=$G(INWARD)
..S PATNM=$$GET1^DIQ(2,DFN,.01,"E")
..S SSN=$$GET1^DIQ(2,DFN,.09,"E"),LAST4=$E(SSN,6,9)
..S MASMOV=$$GET1^DIQ(405.1,TRANTYPE,.04,"E")
..S ^TMP($J,"MMRSCRE","D",LOCNAME,DFN,INDATE)=INLOC_U_DFN_U_INDATE_U_INIFN_U_INTT_U_WARD_U_PATNM_U_LAST4_U_INDATE_U_OUTDATE
..;S ^TMP($J,"MMRSCRE","DETAIL",LOCNAME,INDATE)=WARD_U_PATNM_U_LAST4_U_INDATE
D KVA^VADPT
Q
CNGWARD(LOC,WARD1,WARD2) ;Did patient change wards?
I +$G(LOC)=0 S LOC=$$GETLOC(WARD1,.MMRSLOC2)
I $D(^MMRS(104.3,LOC,1,"B",WARD1)),$D(^MMRS(104.3,LOC,1,"B",WARD2)) Q 0
Q 1
EXCWARD(LOC,WARD) ;Is this ward excluded from the reports?
I +$G(LOC)=0 S LOC=$$GETLOC(WARD,.MMRSLOC2)
I LOC=0 Q 1
I $D(^MMRS(104.3,LOC,1,"B",WARD)) Q 0
Q 1
DUPLOC(LOC,LCTNS) ;
N RSLT,WARD,LOC2
S RSLT=0
S WARD=0 F S WARD=$O(^MMRS(104.3,LOC,1,"B",WARD)) Q:'WARD D
.S LOC2=0 F S LOC2=$O(LCTNS(LOC2)) Q:'LOC2 D
..Q:LOC2=LOC
..I $D(^MMRS(104.3,LOC2,1,"B",WARD)) S RSLT=1
Q RSLT
GETLOC(WARD,LCTNS) ;
N RSLT,LOC
S RSLT=0
S LOC=0 F S LOC=$O(LCTNS(LOC)) Q:'LOC!(RSLT) D
.I $D(^MMRS(104.3,LOC,1,"B",WARD)) S RSLT=LOC
Q RSLT
TRANTYPE(MOVTYPE,TRANTYPE,MOVIEN,DFN) ;
I MOVTYPE=46!(MOVTYPE=5)!(MOVTYPE=6)!(MOVTYPE=7)!(MOVTYPE=47)!(MOVTYPE=27)!(MOVTYPE=33)!(MOVTYPE=3)!(MOVTYPE=22) Q -1 ;MIA/LMT - Removed MOVTYPE 29 ;4/15/10
I MOVTYPE=42!(MOVTYPE=20)!(MOVTYPE=1)!(MOVTYPE=45)!(MOVTYPE=23)!(MOVTYPE=25)!(MOVTYPE=26) Q -1
I MOVTYPE=2!(MOVTYPE=43)!(MOVTYPE=13) Q 3
I MOVTYPE=14!(MOVTYPE=24)!(MOVTYPE=44) Q 1
S TRANTYPE=$$CHKOBS^MMRSIPC2(DFN,MOVIEN,TRANTYPE)
Q TRANTYPE
;
END ;
K ADT,DIV,DIVID,DIVS,ENDDT,HLPLC,LAST4,MASMOV,PATNM,SSN
K STRTDT,WRDLOC,HSPLC
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMMRSCRE2 3649 printed Sep 23, 2025@19:51:11 Page 2
MMRSCRE2 ;TCK - Print CRE Report Cont. (Contains functions to collect patient movements) ; 3/3/17 10:37am
+1 ;;1.0;MDRO PROGRAM TOOLS;**4,5**;Jun 01, 2016;Build 146
+2 ;
GETMOVE ;Collects ward movements for patients that were admitted or discharged in date range.
+1 NEW DUPLOC,MMRSLOC2
+2 DO GETADM(LOC)
+3 ;
GETADM(LOC) ;
+1 NEW TT,MOVDT,MOVIFN,TRANTYPE,INWARD,INDATE,INIFN,INTT,OUTDATE,OUTIFN,OUTTT,NEXTIEN,LOCNAME,VAIP,INLOC
+2 NEW OUTWARD,PREVWARD
+3 FOR TT=1,2
SET MOVDT=STRTDT-.0000001
FOR
SET MOVDT=$ORDER(^DGPM("ATT"_TT,MOVDT))
if (MOVDT>ENDDT)!('MOVDT)
QUIT
Begin DoDot:1
+4 SET MOVIFN=""
FOR
SET MOVIFN=$ORDER(^DGPM("ATT"_TT,MOVDT,MOVIFN))
if 'MOVIFN
QUIT
Begin DoDot:2
+5 DO KVA^VADPT
SET DFN=$PIECE($GET(^DGPM(MOVIFN,0)),"^",3)
SET VAIP("E")=MOVIFN
DO IN5^VADPT
+6 SET TRANTYPE=$$TRANTYPE(+VAIP(4),+VAIP(2),VAIP(1),DFN)
+7 SET PREVWARD=$PIECE(TRANTYPE,U,2)
+8 IF PREVWARD=""
SET PREVWARD=+VAIP(15,4)
+9 SET TRANTYPE=$PIECE(TRANTYPE,U,1)
+10 IF TRANTYPE<1!(TRANTYPE=3)
QUIT
+11 SET INWARD=+VAIP(5)
SET WARD=$$GET1^DIQ(42,INWARD,.01,"E")
+12 IF $GET(INWARD)>0
Begin DoDot:3
+13 SET HSPLC=$$GET1^DIQ(42,INWARD,44,"I")
+14 SET DIV=$$GET1^DIQ(44,HSPLC,3.5,"E")
+15 SET DIVS=$$GET1^DIQ(44,HSPLC,3.5,"I")
+16 SET DIVID=$$GET1^DIQ(40.8,DIVS,1,"I")
SET LOC=$$GET1^DIQ(40.8,DIVS,.01,"I")
End DoDot:3
+17 ;IS THIS WARD EXCLUDED FROM THIS REPORT
+18 if DIV'=LOC
QUIT
+19 SET LOCNAME=LOC
+20 SET WRDLOC(INWARD)=""
+21 IF TRANTYPE=2
IF '$$CNGWARD(LOC,PREVWARD,INWARD)
QUIT
+22 ;SET GLOBAL
+23 SET INDATE=+VAIP(3)
+24 SET INIFN=MOVIFN
+25 SET INTT=TRANTYPE
+26 SET ADT=$$GET1^DIQ(405,MOVIFN,.04,"E")
+27 SET (OUTDATE,OUTIFN,OUTTT)=""
+28 FOR
if (VAIP(16)="")!(OUTIFN)
QUIT
Begin DoDot:3
+29 SET TRANTYPE=$$TRANTYPE(+VAIP(16,3),+VAIP(16,2),VAIP(16),DFN)
+30 SET OUTWARD=$PIECE(TRANTYPE,U,2)
+31 SET NEXTIEN=$PIECE(TRANTYPE,U,3)
+32 SET TRANTYPE=$PIECE(TRANTYPE,U,1)
+33 IF OUTWARD=""
SET OUTWARD=+VAIP(16,4)
+34 IF TRANTYPE=3
SET OUTDATE=+VAIP(16,1)
SET OUTIFN=VAIP(16)
SET OUTTT=3
+35 ;I TRANTYPE=2,$$CNGWARD(LOC,INWARD,OUTWARD) S OUTDATE=+VAIP(16,1),OUTIFN=VAIP(16),OUTTT=2
+36 if OUTIFN
QUIT
+37 IF NEXTIEN=""
SET NEXTIEN=VAIP(16)
+38 DO KVA^VADPT
+39 SET VAIP("E")=NEXTIEN
+40 DO IN5^VADPT
End DoDot:3
+41 SET INLOC=$GET(INWARD)
+42 SET PATNM=$$GET1^DIQ(2,DFN,.01,"E")
+43 SET SSN=$$GET1^DIQ(2,DFN,.09,"E")
SET LAST4=$EXTRACT(SSN,6,9)
+44 SET MASMOV=$$GET1^DIQ(405.1,TRANTYPE,.04,"E")
+45 SET ^TMP($JOB,"MMRSCRE","D",LOCNAME,DFN,INDATE)=INLOC_U_DFN_U_INDATE_U_INIFN_U_INTT_U_WARD_U_PATNM_U_LAST4_U_INDATE_U_OUTDATE
+46 ;S ^TMP($J,"MMRSCRE","DETAIL",LOCNAME,INDATE)=WARD_U_PATNM_U_LAST4_U_INDATE
End DoDot:2
End DoDot:1
+47 DO KVA^VADPT
+48 QUIT
CNGWARD(LOC,WARD1,WARD2) ;Did patient change wards?
+1 IF +$GET(LOC)=0
SET LOC=$$GETLOC(WARD1,.MMRSLOC2)
+2 IF $DATA(^MMRS(104.3,LOC,1,"B",WARD1))
IF $DATA(^MMRS(104.3,LOC,1,"B",WARD2))
QUIT 0
+3 QUIT 1
EXCWARD(LOC,WARD) ;Is this ward excluded from the reports?
+1 IF +$GET(LOC)=0
SET LOC=$$GETLOC(WARD,.MMRSLOC2)
+2 IF LOC=0
QUIT 1
+3 IF $DATA(^MMRS(104.3,LOC,1,"B",WARD))
QUIT 0
+4 QUIT 1
DUPLOC(LOC,LCTNS) ;
+1 NEW RSLT,WARD,LOC2
+2 SET RSLT=0
+3 SET WARD=0
FOR
SET WARD=$ORDER(^MMRS(104.3,LOC,1,"B",WARD))
if 'WARD
QUIT
Begin DoDot:1
+4 SET LOC2=0
FOR
SET LOC2=$ORDER(LCTNS(LOC2))
if 'LOC2
QUIT
Begin DoDot:2
+5 if LOC2=LOC
QUIT
+6 IF $DATA(^MMRS(104.3,LOC2,1,"B",WARD))
SET RSLT=1
End DoDot:2
End DoDot:1
+7 QUIT RSLT
GETLOC(WARD,LCTNS) ;
+1 NEW RSLT,LOC
+2 SET RSLT=0
+3 SET LOC=0
FOR
SET LOC=$ORDER(LCTNS(LOC))
if 'LOC!(RSLT)
QUIT
Begin DoDot:1
+4 IF $DATA(^MMRS(104.3,LOC,1,"B",WARD))
SET RSLT=LOC
End DoDot:1
+5 QUIT RSLT
TRANTYPE(MOVTYPE,TRANTYPE,MOVIEN,DFN) ;
+1 ;MIA/LMT - Removed MOVTYPE 29 ;4/15/10
IF MOVTYPE=46!(MOVTYPE=5)!(MOVTYPE=6)!(MOVTYPE=7)!(MOVTYPE=47)!(MOVTYPE=27)!(MOVTYPE=33)!(MOVTYPE=3)!(MOVTYPE=22)
QUIT -1
+2 IF MOVTYPE=42!(MOVTYPE=20)!(MOVTYPE=1)!(MOVTYPE=45)!(MOVTYPE=23)!(MOVTYPE=25)!(MOVTYPE=26)
QUIT -1
+3 IF MOVTYPE=2!(MOVTYPE=43)!(MOVTYPE=13)
QUIT 3
+4 IF MOVTYPE=14!(MOVTYPE=24)!(MOVTYPE=44)
QUIT 1
+5 SET TRANTYPE=$$CHKOBS^MMRSIPC2(DFN,MOVIEN,TRANTYPE)
+6 QUIT TRANTYPE
+7 ;
END ;
+1 KILL ADT,DIV,DIVID,DIVS,ENDDT,HLPLC,LAST4,MASMOV,PATNM,SSN
+2 KILL STRTDT,WRDLOC,HSPLC
+3 QUIT
+4 ;
