Routine: MMRSCRE2

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

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMMRSCRE2   3649     printed  Apr 23, 2025@18:29:30                                                                                                                                                                                                    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       ;

MMRSCRE2.m