Changeset 1501 for qrda/C0Q/trunk/p


Ignore:
Timestamp:
Aug 2, 2012, 8:59:21 PM (12 years ago)
Author:
Sam Habiel
Message:

Latest routines; T11 copy

Location:
qrda/C0Q/trunk/p
Files:
2 added
14 edited

Legend:

Unmodified
Added
Removed
  • qrda/C0Q/trunk/p/C0QERTIM.m

    r1438 r1501  
    11C0QERTIM        ; Time from admission to leaving a hospital location ; 5/23/12 2:26pm
    2         ;;1.0;C0Q;;May 21, 2012;Build 43
     2        ;;1.0;C0Q;;May 21, 2012;Build 63
    33EN      ;Get Location
    44        S DIC=42,DIC(0)="AEMQ" D ^DIC I Y<1 G EXIT
  • qrda/C0Q/trunk/p/C0QGMRAD.m

    r1438 r1501  
    11C0QGMRAD        ;HIRMFO/RM,WAA-UTILITY TO GATHER PATIENT DATA ;1/15/98  13:47
    2         ;;1.0;C0Q;;May 21, 2012;Build 43
     2        ;;1.0;C0Q;;May 21, 2012;Build 63
    33EN1     ; ENTRY TO GATHER PATIENT A/AR DATA
    44        ;INPUT VARIABLES:
  • qrda/C0Q/trunk/p/C0QGMTSA.m

    r1438 r1501  
    11C0QGMTSA        ; SLC/DLT,KER - Brief Adverse Reaction/Allergy ; 02/27/2002
    2         ;;1.0;C0Q;;May 21, 2012;Build 43
     2        ;;1.0;C0Q;;May 21, 2012;Build 63
    33        ;                 
    44        ; External References
  • qrda/C0Q/trunk/p/C0QGMTSG.m

    r1438 r1501  
    11C0QGMTSG        ; SLC/DLT,KER - Allergies ; 01/06/2003
    2         ;;1.0;C0Q;;May 21, 2012;Build 43
     2        ;;1.0;C0Q;;May 21, 2012;Build 63
    33        ;                 
    44        ; External References
  • qrda/C0Q/trunk/p/C0QHF.m

    r1438 r1501  
    11C0QHF   ; GPL - Health Factor Utility Routines ;9/02/11  17:05
    2         ;;1.0;C0Q;;May 21, 2012;Build 43
     2        ;;1.0;C0Q;;May 21, 2012;Build 63
    33        ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.
  • qrda/C0Q/trunk/p/C0QIMMUN.m

    r1438 r1501  
    11C0QIMMUN        ;Prep Immunization Order data for HL7 Message creation ; 5/23/12 5:40pm
    2         ;;1.0;C0Q;;May 21, 2012;Build 43
     2        ;;1.0;C0Q;;May 21, 2012;Build 63
    33        ;  ^XTMP("C0QIMMUN",0)=purge date^create date
    44        ;  ^XTMP("C0QIMMUN",order_date,order#,item_name)=item_value
  • qrda/C0Q/trunk/p/C0QINIT.m

    r1438 r1501  
    1 C0QINIT ; GPL - Quality Reporting Initialization Routines ; 5/23/12 5:43pm
    2         ;;1.0;C0Q;;May 21, 2012;Build 43
     1C0QINIT ; GPL - Quality Reporting Initialization Routines ; 7/31/12 8:16am
     2        ;;1.0;C0Q;;May 21, 2012;Build 63
    33        ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.
     
    6464        K ZERR
    6565        D CLEAN^DILF
    66         ZWRITE C0QFDA
     66        D ZWRITE^C0QUTIL("C0QFDA")
    6767        D UPDATE^DIE("","C0QFDA","","ZERR")
    6868        I $D(ZERR) S ZZERR=ZZERR ; ZZERR DOESN'T EXIST,
  • qrda/C0Q/trunk/p/C0QKIDS.m

    r1484 r1501  
    1 C0QKIDS ; VEN/SMH - Kids Utilities for transporting C0Q data ; 7/13/12 11:49am
    2         ;;1.0;C0Q;;May 21, 2012;Build 47
     1C0QKIDS ; VEN/SMH - Kids Utilities for transporting C0Q data ; 7/31/12 3:01pm
     2        ;;1.0;C0Q;;May 21, 2012;Build 63
    33        ; Licensed under package license. See Documentation.
    44        ;
    5         ; PEPs: PRE, TRAN, POST
    6         ;
    7 PRE ; Unified Pre; PEP
    8         QUIT
     5        ; PEPs: TRAN, POST, PRE
     6        ;
    97TRAN    ; Unified Transport; PEP
    108        ; D TRAN301  ; looks like I won't send that file over
    11         D TRAN201
     9        D TRAN201 ; C0Q MEASUREMENT
     10        D TRAN101 ; C0Q QUALITY MEASURE
    1211        QUIT
    1312POST    ; Unified Post; PEP
    1413        ; D POST301  ; looks like I won't send that file over
    15         D POST101
    16         D POST201
     14        ; D POST101 ; C0Q QUALITY MEASURE ; As of T11, I won't do that anymore. -->
     15        ; I discovered that it will do it on destination systems that are set-up.
     16        ; So bad bad bad idea for me to do it in a post-init.
     17        ; ... I wrote TRAN101 to do the function of POST101.
     18        D POST201 ; C0Q MEASUREMENT
     19        QUIT
     20        ;
     21PRE     ; Unified Pre; PEP
     22        D PRE101
    1723        QUIT
    1824        ;
    1925        ; << >>
    2026        ;
     27TRAN101 ; Remove Untransportable pointers in C0Q QUALITY MEASURE; Private EP
     28        ; NB: I am reaching into KIDS's data here. This may not work for future versions
     29        ; of KIDS. However, I am exporting this only; once exported, it should work in
     30        ; any version of KIDS.
     31        N XPDIEN S XPDIEN=$QS(XPDGREF,2) ; Get IEN of KIDS Transport Global
     32        N X S X=$NA(^XTMP("XPDT",XPDIEN,"DATA",1130580001.101)) ; KIDS transports our data here
     33        N IEN S IEN=0 ; Looper
     34        F  S IEN=$O(@X@(IEN)) Q:'IEN  D  ; For each IEN, remove the following:
     35        . S $P(@X@(IEN,0),U,2)="" ; Numerator Patient List
     36        . S $P(@X@(IEN,0),U,3)="" ; Denominator Patient List
     37        . S $P(@X@(IEN,7),U,4)="" ; Negative Numerator List
     38        . S $P(@X@(IEN,7),U,2)="" ; Alternate Numerator List
     39        . S $P(@X@(IEN,7),U,3)="" ; Alternate Denominator List
     40        . S $P(@X@(IEN,7),U,5)="" ; Alternate Negative Numerator List
     41        QUIT
     42        ;
    2143TRAN301 ; Grab FDA for entire file C0Q PATIENT LIST and store in Transport Global; Private EP
     44        ; Not used. Dead code.
    2245        N C0QIEN S C0QIEN=0 ; IEN walker
    2346        N C0QREF1 S C0QREF1=$NAME(^TMP("C0QOLD",$J)) ; Temporary Global Reference
     
    5679        ;
    5780POST201 ; File FDA for 201; Private EP
     81        ;
     82        ; Clean-up data if it already exists!
     83        ; ZWRITE ^C0Q(201,:,5,:,0)       
     84        ; ^C0Q(201,1,5,599,0)=50
     85        ; ^C0Q(201,1,5,600,0)=4
     86        ; ^C0Q(201,1,5,601,0)=39
     87        ; ^C0Q(201,1,5,602,0)=6
     88        ; ^C0Q(201,1,5,603,0)=7
     89        ; ^C0Q(201,1,5,604,0)=48
     90        ; ^C0Q(201,1,5,605,0)=46
     91        ;
    5892        IF $O(^C0Q(201,0)) DO  QUIT  ; Quit if data is already there.
    5993        . D MES^XPDUTL("Data exists in file C0Q MEASUREMENTS... Not adding new data")
     94        . D MES^XPDUTL("Cleaning up broken pointers in C0Q MEASUREMENTS from deleted data in C0Q QUALITY MEASURE")
     95        . ; This is very hairy code. Run through the 5 multiple in C0Q MEASUREMENT
     96        . ; Grab the IEN in the .01, check if it exists; if not, kill.
     97        . N DA,DIK ; DIK Variables; as well as our looper variables
     98        . S (DA,DA(1))=0 ; Initial looper values
     99        . F  S DA(1)=$O(^C0Q(201,DA(1))) Q:'DA(1)  D  ; Loop through entries
     100        . . D MES^XPDUTL("...Processing entry "_$P(^C0Q(201,DA(1),0),U))  ; msg
     101        . . S DIK="^C0Q(201,"_DA(1)_",5,"  ; deletion root for the next loop
     102        . . F  S DA=$O(^C0Q(201,DA(1),5,DA)) Q:'DA  D  ; For each Measure
     103        . . . N IEN S IEN=+^C0Q(201,DA(1),5,DA,0)  ; Get IEN
     104        . . . I IEN,'$D(^C0Q(101,IEN)) D  ; If IEN is numeric, IEN exists in dest file
     105        . . . . D MES^XPDUTL("......Deleting broken pointer "_IEN) ; msg
     106        . . . . D ^DIK ; delete
     107        ;
     108        ; If new install, add data
    60109        ;
    61110        D MES^XPDUTL("Adding data to C0Q MEASUREMENTS")
     
    70119        ;
    71120POST301 ; Get FDA from Transport Global and install in destination system for C0Q PATIENT LIST; Private EP
     121        ; Not used. Dead code.
    72122        N C0QFDA S C0QFDA=$NAME(@XPDGREF@("C0Q","1130580001.301")) ; FDA array name is the global reference
    73123        N C0QERR ; Error
     
    79129        QUIT
    80130        ;
    81 POST101 ; Clean transported data from broken pointers in C0Q QUALITY MEASURE in destination systems; Private EP
    82         D MES^XPDUTL("Cleaning C0Q QUALITY MEASURE data")
    83         N C0QIEN S C0QIEN=0 ; Ien looper
    84         N C0QFDA ; Fileman Data Array
    85         F  S C0QIEN=$O(^C0Q(101,C0QIEN)) Q:'+C0QIEN  DO  ; For each record, delete these fields
    86         . S C0QFDA(1130580001.101,C0QIEN_",",1)="@" ; NUMERATOR PATIENT LIST
    87         . S C0QFDA(1130580001.101,C0QIEN_",",1.5)="@" ; NEGATIVE NUMERATOR LIST
    88         . S C0QFDA(1130580001.101,C0QIEN_",",2)="@" ; DENOMINATOR PATIENT LIST
    89         . ; ---
    90         . ; I wasn't planning on emptying these out, but the IENs in desintation systems may be different
    91         . ; so it is best to remove them for now. It's a pointer field, so IENs are important.
    92         . ; Desination file is populated automatically, but only at the site, and only after config.
    93         . ; So we can't really ship the pointers as part of the install.
    94         . ; ---
    95         . S C0QFDA(1130580001.101,C0QIEN_",",1.1)="@" ; ALTERNATIVE NUMERATOR LIST
    96         . S C0QFDA(1130580001.101,C0QIEN_",",1.51)="@" ; ALTERNATE NEGATIVE NUM LIST
    97         . S C0QFDA(1130580001.101,C0QIEN_",",2.1)="@" ; ALTERNATIVE DENOMINATOR LIST
    98         N C0QERR ; Errors
    99         D FILE^DIE("","C0QFDA","C0QERR") ; Do it!
    100         I $D(C0QERR) D  ; if there's an error, print it out
    101         . D MES^XPDUTL("Couldn't fix data into C0Q QUALITY MEASURE file")
    102         . S C0QERR=$Q(C0QERR)
    103         . F  S C0QERR=$Q(@C0QERR) Q:C0QERR=""  D MES^XPDUTL(C0QERR_": "_@C0QERR)
    104         QUIT
    105         ;
    106         ; Code below taken from PXRMP15I
    107         ;===============================================================
     131PRE101  ; Clean existing data (from an earlier installation) from measures that are now merged to other measures
     132        ; in C0Q QUALITY MEASURE in destination systems; Private EP
     133        ;
     134        ; Quit if C0Q Quality Measures isn't on the system.
     135        Q:'$D(^C0Q(101))
     136        ;
     137        D MES^XPDUTL("Removing subsumed entries in C0Q QUALITY MEASURE")
     138        ;
     139        ; .01 field values to for records to remove
     140        N C0QLIST
     141        S C0QLIST("TEST M0028A")=""
     142        S C0QLIST("MU EP 0028B")=""
     143        S C0QLIST("M0013")=""
     144        S C0QLIST("M0024")=""
     145        S C0QLIST("M1")=""
     146        S C0QLIST("M3")=""
     147        S C0QLIST("M2")=""
     148        S C0QLIST("M0028")=""
     149        S C0QLIST("M111")=""
     150        S C0QLIST("M112")=""
     151        S C0QLIST("M113")=""
     152        S C0QLIST("M128")=""
     153        S C0QLIST("M5")=""
     154        S C0QLIST("M7")=""
     155        S C0QLIST("M0022")=""
     156        S C0QLIST("12")=""
     157        S C0QLIST("M0038")=""
     158        S C0QLIST("M110")=""
     159        S C0QLIST("MU EP NQF 0070")=""
     160        ;
     161        ; Root for ^DIK
     162        N DIK S DIK="^C0Q(101,"
     163        ;
     164        ; Loop through list, find IEN for each one, kill off
     165        N C0QITEM S C0QITEM=""                             ; Item
     166        F  S C0QITEM=$O(C0QLIST(C0QITEM)) Q:C0QITEM=""  D  ; Loop
     167        . Q:'$DATA(^C0Q(101,"B",C0QITEM))                  ; Quit if not present.
     168        . N DA S DA=$O(^C0Q(101,"B",C0QITEM,""))           ; IEN
     169        . ; The original software has MU EP NQF 0070 incorrectly. If the 1 node
     170        . ; has Pneumonia, we want to remove that entry.
     171        . I C0QITEM="MU EP NQF 0070",^C0Q(101,DA,1)'["Pneumonia" QUIT
     172        . D MES^XPDUTL("...Removing "_C0QITEM)                ; Message to user
     173        . D ^DIK                                           ; Delete
     174        ;
     175REN     ; Rename a bunch of entries
     176        ; ("OLD NAME")="NEW NAME"
     177        D MES^XPDUTL("Renaming Old entries in C0Q QUALITY MEASURE")
     178        ;
     179        N C0QLIST
     180        S C0QLIST("NQF0038 NUM1 DPT")="MU EP NQF 0038 NUM1 DPT"
     181        S C0QLIST("NQF0038 NUM10")="MU EP NQF 0038 NUM10 FLU"
     182        S C0QLIST("NQF0038 NUM11 COMBO5")="MU EP NQF 0038 NUM11 COMBO5"
     183        S C0QLIST("NQF0038 NUM12 COMBO6")="MU EP NQF 0038 NUM12 COMBO6"
     184        S C0QLIST("NQF0038 NUM2 IPV")="MU EP NQF 0038 NUM2 IPV"
     185        S C0QLIST("NQF0038 NUM3 MMR")="MU EP NQF 0038 NUM3 MMR"
     186        S C0QLIST("NQF0038 NUM4 HiB")="MU EP NQF 0038 NUM4 HiB"
     187        S C0QLIST("NQF0038 NUM5 HEP B")="MU EP NQF 0038 NUM5 HEP B"
     188        S C0QLIST("NQF0038 NUM6 VZV")="MU EP NQF 0038 NUM6 VZV"
     189        S C0QLIST("NQF0038 NUM7 PCV")="MU EP NQF 0038 NUM7 PCV"
     190        S C0QLIST("NQF0038 NUM8 HEP A")="MU EP NQF 0038 NUM8 HEP A"
     191        S C0QLIST("NQF0038 NUM9")="MU EP NQF 0038 NUM9 RV"
     192        S C0QLIST("M124")="PQRI MEASURE 124"
     193        S C0QLIST("M173")="PQRI MEASURE 173"
     194        S C0QLIST("M39")="PQRI MEASURE 39"
     195        S C0QLIST("M47")="PQRI MEASURE 47"
     196        S C0QLIST("M48")="PQRI MEASURE 48"
     197        ;
     198        N C0QITEM S C0QITEM=""                              ; Item
     199        N C0QFDA                                            ; FDA
     200        F  S C0QITEM=$O(C0QLIST(C0QITEM))  Q:C0QITEM=""  D  ; Loop through
     201        . N IEN S IEN=$O(^C0Q(101,"B",C0QITEM,""))          ; Get IEN from File using old name
     202        . I IEN S C0QFDA(1130580001.101,IEN_",",.01)=C0QLIST(C0QITEM)  ; If found, put new name in FDA for this IEN
     203        . I IEN D MES^XPDUTL("...Renaming "_C0QITEM_" to "_C0QLIST(C0QITEM)) ; Print message to user
     204        ;
     205        N C0QERR                                            ; Error for FILE^DIE
     206        I $D(C0QFDA) D FILE^DIE("E",$NA(C0QFDA),$NA(C0QERR))  ; File if FDA has contents
     207        E  D MES^XPDUTL("No entries to rename")             ; If nothing, tell user so
     208        ;
     209        D:$D(C0QERR)                                        ; If Error, print it
     210        . D MES^XPDUTL("Error Filing Data. FILE^DIE reported:")
     211        . N REF S REF=$NA(C0QERR)                           ; $Q Reference
     212        . F  S REF=$Q(@REF) Q:REF=""  D MES^XPDUTL(REF_"="_@REF) ; Loop and Print
     213        ;
     214        QUIT
  • qrda/C0Q/trunk/p/C0QMAIN.m

    r1438 r1501  
    11C0QMAIN ; GPL - Quality Reporting Main Processing ;10/13/10  17:05
    2         ;;1.0;C0Q;;May 21, 2012;Build 43
     2        ;;1.0;C0Q;;May 21, 2012;Build 63
    33        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.
  • qrda/C0Q/trunk/p/C0QMU12.m

    r1445 r1501  
    1 C0QMU12 ;JJOH/ZAG/GPL - Patient Reminder List ; 5/30/12 11:28am
    2         ;;1.0;C0Q;;May 21, 2012;Build 44
     1C0QMU12 ;JJOH/ZAG/GPL - Patient Reminder List ; 7/31/12 12:34pm
     2        ;;1.0;C0Q;;May 21, 2012;Build 63
    33        ;
    44        ;2011 Zach Gonzales<zach@linux.com> - Licensed under the terms of the GNU
    55        ;General Public License See attached copy of the License.
    6         ;
    7         ;This program is free software; you can redistribute it and/or modify
    8         ;it under the terms of the GNU General Public License as published by
    9         ;the Free Software Foundation; either version 2 of the License, or
    10         ;(at your option) any later version.
    11         ;
    12         ;This program is distributed in the hope that it will be useful,
    13         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    14         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    15         ;GNU General Public License for more details.
    16         ;
    17         ;You should have received a copy of the GNU General Public License along
    18         ;with this program; if not, write to the Free Software Foundation, Inc.,
    19         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    206        ;
    217        ; GPL - THIS ROUTINE IS A COPY OF JJOHMU11 THAT HAS BEEN MODIFIED
     
    7763        . D ALL ; all currently admitted patients in the hospital
    7864        . D DIS ; all patients discharged since the reporting period began
    79         . I C0QSS ZWRITE GRSLT
     65        . I C0QSS D ZWRITE^C0QUTIL("GRSLT")
    8066        . ;D ICUPAT ; GENERATE ICU PATIENT LIST
    8167        . I C0QPL D  ;
     
    11197        . . N DFN,RB S DFN=""
    11298        . . F  S DFN=$O(^DPT("CN",WARD,+DFN)) Q:'DFN  D  ;DFN of patient on ward
    113         . . . D DEMO
     99        . . . D DEMO^C0QMU122
    114100        . . . D PROBLEM
    115101        . . . D ALLERGY
     
    122108        . . . D COD
    123109        . . . D EDTIME
    124         . . . I C0QPR D PRINT
    125         . . . I C0QSS D SS
    126         . . . I C0QPL D PATLIST
    127         Q
    128         ;
    129 DEMO    ; patient demographics
    130         K PTDOB
    131         N PTNAME,PTSEX,PTHRN,PTRLANG,PTLANG,RACE,RACEDSC,ETHN,ETHNDSC,RB
    132         S PTNAME=$P(^DPT(DFN,0),U) ;patient name
    133         S PTDOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3)) ;date of birth
    134         S PTSEX=$P($G(^DPT(DFN,0)),U,2) ;patient sex
    135         D PID^VADPT ;VADPT call to grab PISD based on PT Eligibility
    136         S PTHRN=$P($G(VA("PID")),U) ;health record number
    137         S PTRLANG=$P($G(^DPT(DFN,256000)),U) ;ptr to language file
    138         I $G(PTRLANG)'="" S PTLANG=$P(^DI(.85,PTRLANG,0),U) ;PLS extrnl
    139         S RACE=""
    140         F  D  Q:RACE=""
    141         . S RACE=$O(^DPT(DFN,.02,"B",RACE)) ;race code IEN
    142         . Q:'RACE
    143         . S RACEDSC=$P($G(^DIC(10,RACE,0)),U) ;race description
    144         S ETHN=""
    145         F  D  Q:ETHN=""
    146         . S ETHN=$O(^DPT(DFN,.06,"B",ETHN)) ;ethnicity IEN
    147         . Q:'ETHN
    148         . S ETHNDSC=$P($G(^DIC(10.2,ETHN,0)),U) ;ethnincity description
    149         S RB=$P($G(^DPT(DFN,.101)),U) ;room and bed
    150         N DEMOYN S DEMOYN=1
    151         I $G(PTSEX)="" S DEMOYN=0
    152         I $G(PTDOB)="" S DEMOYN=0
    153         I $G(PTHRN)="" S DEMOYN=0
    154         I $G(PTLANG)="" S DEMOYN=0
    155         I $G(RACEDSC)="" S DEMOYN=0
    156         I $G(ETHNDSC)="" S DEMOYN=0
    157         I DEMOYN S C0QLIST(ZYR_"HasDemographics",DFN)=""
    158         E  S C0QLIST(ZYR_"FailedDemographics",DFN)=""
     110        . . . I C0QPR D PRINT^C0QMU121
     111        . . . I C0QSS D SS^C0QMU121
     112        . . . I C0QPL D PATLIST^C0QMU121
    159113        Q
    160114        ;
     
    264218        Q
    265219        ;
    266 SMOKING ;
    267         ; WANT TO CHANGE SMOKING STATUS CHECKING FOR 2012 TO A SIMPLE SET OF
    268         ; HEALTH FACTORS. GPL
    269         I $$INLIST(ZYR_"HasSmokingStatus",DFN) D  Q  ; ALREADY HAS SMOKING STAT CHECK
    270         . S C0QLIST(ZYR_"HasSmokingStatus",DFN)=""
    271         . S C0QLIST(ZYR_"Over12",DFN)=""
    272         I $$INLIST(ZYR_"NoSmokingStatus",DFN) D  Q  ; ALREADY HAS SMOKING STATUS CHECK
    273         . S C0QLIST(ZYR_"NoSmokingStatus",DFN)=""
    274         . S C0QLIST(ZYR_"Over12",DFN)=""
    275         N C0QSMOKE,C0QSYN
    276         S C0QSYN=0
    277         I $$AGE^C0QUTIL(DFN)<13 Q  ; DON'T CHECK UNDER AGE 13
    278         D HFCAT^C0QHF(.C0QSMOKE,DFN,"TOBACCO") ; GET ALL HEALTH FACTORS FOR THE
    279         ; PATIENT IN THE CATEGORY OF TOBACCO
    280         I $D(C0QSMOKE) S C0QSYN=1
    281         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Quit Smokeless Tobacco <1 Yr Ago")
    282         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Quit Smokeless Tobacco > 20 Yrs Ago")
    283         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Quit Smokeless Tobacco: 1-5 Yrs Ago")
    284         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Quit Smokeless Tobacco: 10-20 Yrs Ago")
    285         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Quit Smokeless Tobacco: 5-10 Yrs Ago")
    286         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Quit Smoking")
    287         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Quit Smoking < 1 Yr Ago")
    288         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Quit Smoking > 20 Yrs Ago")
    289         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Quit Smoking: 1-5 Yrs Ago")
    290         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Quit Smoking: 10-20 Yrs Ago")
    291         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Quit Smoking: 5-10 Yrs Ago")
    292         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKELESS TOBACCO USER")
    293         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKELESS: 1-5 YRS AGO")
    294         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKELESS: 10-20 YRS AGO")
    295         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKELESS: 5-10 YRS AGO")
    296         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKELESS: < 1 YR AGO")
    297         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKELESS: > 20 YRS AGO")
    298         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKER")
    299         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKER 10-20 YRS")
    300         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKER 20+ YRS")
    301         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKER < 1 YR")
    302         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKER < 1 YR AGO")
    303         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKER > 20 YRS AGO")
    304         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKER: 1-5 YRS")
    305         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKER: 1-5 YRS AGO")
    306         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKER: 10-20 YRS AGO")
    307         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKER: 5-10 YRS")
    308         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKER: 5-10 YRS AGO")
    309         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"PREVIOUS SMOKELESS TOBACCO USER")
    310         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"LIFETIME NON-SMOKER")
    311         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smokeless Tobacco User")
    312         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smoker")
    313         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smoker (PMH)")
    314         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoke Exposure/2nd Hand Exposure")
    315         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 1-5 Yrs")
    316         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 10-20 Yrs")
    317         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 5-10 Yrs")
    318         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For < 1 Yr")
    319         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For > 20 Yrs")
    320         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Tobacco User")
    321         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 1-5 Yrs")
    322         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 10-20 Yrs")
    323         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 5-10 Yrs")
    324         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for < 1 Yr")
    325         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for > 20 Yrs")
    326         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoker (HPI)")
    327         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoking (FMH)")
    328         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoking (PMH)")
    329         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoking Cessation (OPH)")
    330         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"LIFETIME NON-SMOKER")
    331         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smokeless Tobacco User")
    332         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smoker")
    333         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smoker (PMH)")
    334         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoke Exposure/2nd Hand Exposure")
    335         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 1-5 Yrs")
    336         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 10-20 Yrs")
    337         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 5-10 Yrs")
    338         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For < 1 Yr")
    339         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For > 20 Yrs")
    340         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Tobacco User")
    341         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 1-5 Yrs")
    342         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 10-20 Yrs")
    343         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 5-10 Yrs")
    344         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for < 1 Yr")
    345         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for > 20 Yrs")
    346         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoker (HPI)")
    347         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoking (FMH)")
    348         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoking (PMH)")
    349         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Non-Smoker")
    350         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"LIFETIME NON-SMOKER")
    351         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smokeless Tobacco User")
    352         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smoker")
    353         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smoker (PMH)")
    354         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoke Exposure/2nd Hand Exposure")
    355         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 1-5 Yrs")
    356         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 10-20 Yrs")
    357         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 5-10 Yrs")
    358         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For < 1 Yr")
    359         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For > 20 Yrs")
    360         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Tobacco User")
    361         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 1-5 Yrs")
    362         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 10-20 Yrs")
    363         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 5-10 Yrs")
    364         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for < 1 Yr")
    365         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for > 20 Yrs")
    366         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoker (HPI)")
    367         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoking (FMH)")
    368         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoking (PMH)")
    369         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"LIFETIME NON-SMOKER")
    370         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smokeless Tobacco User")
    371         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smoker")
    372         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smoker (PMH)")
    373         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoke Exposure/2nd Hand Exposure")
    374         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 1-5 Yrs")
    375         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 10-20 Yrs")
    376         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 5-10 Yrs")
    377         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For < 1 Yr")
    378         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For > 20 Yrs")
    379         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Tobacco User")
    380         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 1-5 Yrs")
    381         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 10-20 Yrs")
    382         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 5-10 Yrs")
    383         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for < 1 Yr")
    384         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for > 20 Yrs")
    385         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoker (HPI)")
    386         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoking (FMH)")
    387         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoking (PMH)")
    388         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Non-Smoker")
    389         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"LIFETIME NON-SMOKER")
    390         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smokeless Tobacco User")
    391         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smoker")
    392         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Former Smoker (PMH)")
    393         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoke Exposure/2nd Hand Exposure")
    394         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 1-5 Yrs")
    395         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 10-20 Yrs")
    396         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For 5-10 Yrs")
    397         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For < 1 Yr")
    398         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoked For > 20 Yrs")
    399         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Tobacco User")
    400         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 1-5 Yrs")
    401         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 10-20 Yrs")
    402         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for 5-10 Yrs")
    403         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for < 1 Yr")
    404         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smokeless Used for > 20 Yrs")
    405         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoker (HPI)")
    406         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoking (FMH)")
    407         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Smoking (PMH)")
    408         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Non-Smoker")
    409         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Non-Smoker (PMH)")
    410         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Non-Tobacco User")
    411         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Current Smoker - No")
    412         S:'C0QSYN C0QSYN=$$HFYN^C0QHF(DFN,"Current Smoker - Yes")
    413         S C0QLIST(ZYR_"Over12",DFN)=""
    414         ;N GT
    415         ;S GT(1,"HasSmokingStatus","SMOK")=""
    416         ;S GT(2,"HasSmokingStatus","Smok")=""
    417         ;S GT(3,"HasSmokingStatus","smok")=""
    418         ;I 'C0QSYN D  ;
    419         ;. N G
    420         ;. S OK=$$TXTALL^C0QNOTES(.G,.GT,DFN)
    421         ;. I $D(G) S C0QSYN=1
    422         I C0QSYN S C0QLIST(ZYR_"HasSmokingStatus",DFN)=""
    423         E  S C0QLIST(ZYR_"NoSmokingStatus",DFN)=""
    424         Q
    425         ;
     220SMOKING G SMOKING^C0QMU121
    426221VITALS  ;
    427222        ;
     
    512307ED1     ;
    513308        S ZYR="MU12-"
    514         D DOTIME("ED DEPARTURE TIME")
     309        D DOTIME^C0QMU121("ED DEPARTURE TIME")
    515310        Q
    516311        ;
    517312ED2     ;
    518313        S ZYR="MU12-"
    519         D DOTIME2("TIME DECISION TO ADMIT MADE")
    520         Q
    521         ;
    522 DOTIME(ZHF)     ; COMPUTE THE MEAN TIME IN THE ED FROM ARRIVAL TO DEPARTURE
    523         ; THIS IS A QUALITY MEASURE ED-1 FOR MEANINGFUL USE
    524         ; IT PRINTS A REPORT OF EACH PATIENT WITH THE ED TIMES RECORDED
    525         ; AND THEIR TIME. AT THE END IT PRINTS THE MEAN TIME
    526         N ZP
    527         S ZP=$$PATLN(ZYR_"HasEDtime") ; patient list name for patients to process
    528         S ZHFN=9000010.23 ; FILE NUMBER FOR V HEALTH FACTORS
    529         S ZVFN=9000010 ; VISIT FILE NUMBER
    530         K ZARY1,ZARY2
    531         N ZI S ZI=""
    532         S COUNT=0
    533         F  S ZI=$O(@ZP@(ZI)) Q:ZI=""  D  ; FOR EACH PATIENT
    534         . S COUNT=COUNT+1
    535         . N ZA,ZD
    536         . S ZA=$$VHFIEN^C0QHF(ZI,"ED ARRIVAL TIME") ; IEN OF ARRIVAL HEALTH FACTOR
    537         . S ZD=$$VHFIEN^C0QHF(ZI,ZHF) ; IEN OF DEPART HEALTH FACTOR
    538         . N ZAD,ZDD ; ARRIVAL DATE, DEPARTURE DATE
    539         . N ZAC,ZDC ; ARRIVAL COMMENT, DEPARTURE COMMENT
    540         . ; THE COMMENT IS THE TIME XXYY
    541         . N OK,TMP
    542         . S TMP=$$GET1^DIQ(ZHFN,ZA_",",.03,"I") ; VISIT POINTER
    543         . S ZAD=$$GET1^DIQ(ZVFN,TMP_",",.01,"I") ; VISIT DATE
    544         . ;S ZAD=$P(^AUPNVHF(ZA,0),U,3) ; DATE IS PIECE 3
    545         . S TMP=$$GET1^DIQ(ZHFN,ZD_",",.03,"I") ; VISIT POINTER
    546         . S ZDD=$$GET1^DIQ(ZVFN,TMP_",",.01,"I") ; VISIT DATE
    547         . ;S ZDD=$$GET1^DIQ(ZHFN,ZD_",",1201,"I") ; EVENT DATE FIELD
    548         . ;S ZDD=$P(^AUPNVHF(ZD,0),U,3) ; DATE IS PIECE 3
    549         . ;S OK=$$GET1^DIQ(ZHFN,ZA_",",81101,"","ZAC") ; ARRIVAL TIME
    550         . S ZAC=$G(^AUPNVHF(ZA,811)) ; THE TIME
    551         . ;S OK=$$GET1^DIQ(ZHFN,ZD_",",81101,"","ZDC") ; DEPARTURE TIME
    552         . S ZDC=$G(^AUPNVHF(ZD,811)) ; DEPARTURE TIME
    553         . N ZT ; THE TIME DIFFERENCE BETWEEN THE DATES
    554         . W !,!,"PATIENT: ",ZI," ",$P(^DPT(ZI,0),U,1)
    555         . W !,"IN: ",$$FMTE^XLFDT(ZAD_"."_ZAC)," OUT: ",$$FMTE^XLFDT(ZDD_"."_ZDC)
    556         . S G1=($E(ZDC,1,2)*60)+($E(ZDC,3,4))
    557         . S G2=($E(ZAC,1,2)*60)+($E(ZAC,3,4))
    558         . I (ZDD-ZAD)>0 S G1=G1+(((ZDD-ZAD)*24)*60)
    559         . S GTOT=G1-G2
    560         . W !,"TIME: ",GTOT," ESTIMATED"
    561         . S ZT=$$DTDIFF^C0QUTIL(ZDD,ZDC,ZAD,ZAC) ; COMPUTE THE DIFFERENCE IN MINUTES
    562         . W !,"COMPUTED MINUTES: ",ZT
    563         . ;I ZT'=GTOT B  ; LET'S FIND OUT WHAT'S WRONG
    564         . I ZT<0 D  Q  ; SKIP PATIENTS WITH NEGATIVE TIMES
    565         . . W !,"****EXCLUDED****"
    566         . I ZT>400000 D  Q  ; THESE ARE ERRORS
    567         . . W !,"****EXCLUDED****"
    568         . S ZARY1(ZT,ZI)="" ; ARRAY ORDERED BY MINUTES OF PATIENTS
    569         N ZY,ZZ S ZY="" S ZZ=""
    570         N ZCOUNT S ZCOUNT=0
    571         F  S ZY=$O(ZARY1(ZY)) Q:ZY=""  D  ; FOR EACH TIME
    572         . F  S ZZ=$O(ZARY1(ZY,ZZ)) Q:ZZ=""  D  ; FOR EACH PATIENT WITH THIS TIME
    573         . . S ZCOUNT=ZCOUNT+1
    574         . . S ZARY2(ZCOUNT,ZY,ZZ)=""
    575         . . ;W !,ZCOUNT," PATIENT: ",ZZ," MINUTES: ",ZY
    576         N ZMID
    577         S ZMID=$P(ZCOUNT/2,".")
    578         W !,"NUMBER OF PATIENTS IN REPORT: ",ZCOUNT
    579         W !,"ED ARRIVAL TIME UNTIL ",ZHF
    580         W !,"MEDIAN TIME: ",$O(ZARY2(ZMID,""))
    581         Q
    582         ;
    583 DOTIME2(ZHF)    ; COMPUTE THE MEAN TIME IN THE ED FROM ARRIVAL TO DEPARTURE
    584         ; THIS IS A QUALITY MEASURE ED-1 FOR MEANINGFUL USE
    585         ; IT PRINTS A REPORT OF EACH PATIENT WITH THE ED TIMES RECORDED
    586         ; AND THEIR TIME. AT THE END IT PRINTS THE MEAN TIME
    587         N ZP
    588         S ZP=$$PATLN(ZYR_"HasEDtime") ; patient list name for patients to process
    589         S ZHFN=9000010.23 ; FILE NUMBER FOR V HEALTH FACTORS
    590         S ZVFN=9000010 ; VISIT FILE NUMBER
    591         K ZARY1,ZARY2
    592         N ZI S ZI=""
    593         S COUNT=0
    594         F  S ZI=$O(@ZP@(ZI)) Q:ZI=""  D  ; FOR EACH PATIENT
    595         . S COUNT=COUNT+1
    596         . N ZA,ZD
    597         . ;S ZA=$$VHFIEN^C0QHF(ZI,"ED ARRIVAL TIME") ; IEN OF ARRIVAL HEALTH FACTOR
    598         . ;S ZD=$$VHFIEN^C0QHF(ZI,ZHF) ; IEN OF DEPART HEALTH FACTOR
    599         . S ZA=$$VHFIEN^C0QHF(ZI,ZHF) ; IEN OF DEPART HEALTH FACTOR
    600         . S ZD=$$VHFIEN^C0QHF(ZI,"ED DEPARTURE TIME") ; IEN OF ARRIVAL HEALTH FACTOR
    601         . N ZAD,ZDD ; ARRIVAL DATE, DEPARTURE DATE
    602         . N ZAC,ZDC ; ARRIVAL COMMENT, DEPARTURE COMMENT
    603         . ; THE COMMENT IS THE TIME XXYY
    604         . N OK,TMP
    605         . S TMP=$$GET1^DIQ(ZHFN,ZA_",",.03,"I") ; VISIT POINTER
    606         . S ZAD=$$GET1^DIQ(ZVFN,TMP_",",.01,"I") ; VISIT DATE
    607         . ;S ZAD=$P(^AUPNVHF(ZA,0),U,3) ; DATE IS PIECE 3
    608         . S TMP=$$GET1^DIQ(ZHFN,ZD_",",.03,"I") ; VISIT POINTER
    609         . S ZDD=$$GET1^DIQ(ZVFN,TMP_",",.01,"I") ; VISIT DATE
    610         . ;S ZDD=$$GET1^DIQ(ZHFN,ZD_",",1201,"I") ; EVENT DATE FIELD
    611         . ;S ZDD=$P(^AUPNVHF(ZD,0),U,3) ; DATE IS PIECE 3
    612         . ;S OK=$$GET1^DIQ(ZHFN,ZA_",",81101,"","ZAC") ; ARRIVAL TIME
    613         . S ZAC=$G(^AUPNVHF(ZA,811)) ; THE TIME
    614         . ;S OK=$$GET1^DIQ(ZHFN,ZD_",",81101,"","ZDC") ; DEPARTURE TIME
    615         . S ZDC=$G(^AUPNVHF(ZD,811)) ; DEPARTURE TIME
    616         . N ZT ; THE TIME DIFFERENCE BETWEEN THE DATES
    617         . W !,!,"PATIENT: ",ZI," ",$P(^DPT(ZI,0),U,1)
    618         . W !,"IN: ",$$FMTE^XLFDT(ZAD_"."_ZAC)," OUT: ",$$FMTE^XLFDT(ZDD_"."_ZDC)
    619         . S G1=($E(ZDC,1,2)*60)+($E(ZDC,3,4))
    620         . S G2=($E(ZAC,1,2)*60)+($E(ZAC,3,4))
    621         . I (ZDD-ZAD)>0 S G1=G1+(((ZDD-ZAD)*24)*60)
    622         . S GTOT=G1-G2
    623         . W !,"TIME: ",GTOT," ESTIMATED"
    624         . S ZT=$$DTDIFF^C0QUTIL(ZDD,ZDC,ZAD,ZAC) ; COMPUTE THE DIFFERENCE IN MINUTES
    625         . W !,"COMPUTED MINUTES: ",ZT
    626         . ;I ZT'=GTOT B  ; LET'S FIND OUT WHAT'S WRONG
    627         . I ZT<0 D  Q  ; SKIP PATIENTS WITH NEGATIVE TIMES
    628         . . W !,"****EXCLUDED****"
    629         . I ZT>400000 D  Q  ; THESE ARE ERRORS
    630         . . W !,"****EXCLUDED****"
    631         . S ZARY1(ZT,ZI)="" ; ARRAY ORDERED BY MINUTES OF PATIENTS
    632         N ZY,ZZ S ZY="" S ZZ=""
    633         N ZCOUNT S ZCOUNT=0
    634         F  S ZY=$O(ZARY1(ZY)) Q:ZY=""  D  ; FOR EACH TIME
    635         . F  S ZZ=$O(ZARY1(ZY,ZZ)) Q:ZZ=""  D  ; FOR EACH PATIENT WITH THIS TIME
    636         . . S ZCOUNT=ZCOUNT+1
    637         . . S ZARY2(ZCOUNT,ZY,ZZ)=""
    638         . . ;W !,ZCOUNT," PATIENT: ",ZZ," MINUTES: ",ZY
    639         N ZMID
    640         S ZMID=$P(ZCOUNT/2,".")
    641         W !,"NUMBER OF PATIENTS IN REPORT: ",ZCOUNT
    642         W !,"ED ARRIVAL TIME UNTIL ",ZHF
    643         W !,"MEDIAN TIME: ",$O(ZARY2(ZMID,""))
     314        D DOTIME2^C0QMU121("TIME DECISION TO ADMIT MADE")
    644315        Q
    645316        ;
     
    665336        I $D(^C0Q(301,ZL,1,"B",DFN)) S ZR=1 ; PATIENT IS IN LIST
    666337        Q ZR
    667         ;
    668         ; LOOK AT GETTING RID OF PRINT AND SS AS THEY ARE NOT BEING USED. GPL
    669 PRINT   ; PRINT TO SCREEN
    670         I $D(WARD) W !!,WARD_"-"_WARDNAME_" "_RB_": "_PTNAME_"("_PTSEX_") "
    671         I $D(EXDTE) D  ;
    672         . W !,"Discharge Date: ",EXDTE
    673         . W !,DFN," ",PTNAME
    674         W !,"DOB: ",PTDOB," HRN: ",PTHRN
    675         W !,"Language Spoken: ",$G(PTLANG)
    676         W !,"Race: ",RACEDSC
    677         W !,"Ethnicity: ",$G(ETHNDSC)
    678         W !,"Problems: "
    679         W !,PBDESC
    680         W !,"Allergies: "
    681         W !,ALDESC
    682         W !,"Medications: "
    683         W !
    684         Q
    685         ;
    686 SS      ; CREATE SPREADSHEET ARRAY
    687         S G1("Patient")=DFN
    688         I $D(WARD) D  ;
    689         . S G1("WardName")=WARDNAME
    690         . S G1("RoomAndBed")=RB
    691         I $D(EXDTE) D  ;
    692         . S G1("DischargeDate")=EXDTE
    693         S G1("PatientName")=PTNAME
    694         S G1("Gender")=PTSEX
    695         S G1("DateOfBirth")=PTDOB
    696         S G1("HealthRecordNumber")=PTHRN
    697         S G1("LanguageSpoken")=$G(PTLANG)
    698         S G1("Race")=RACEDSC
    699         S G1("Ehtnicity")=$G(ETHNDSC)
    700         S G1("Problem")=PBDESC
    701         I PBDESC["No problems found" S G1("HasProblem")=0
    702         E  S G1("HasProblem")=1
    703         S G1("Allergies")=ALDESC
    704         I ALDESC["No Allergy" S G1("HasAllergy")=0
    705         E  S G1("HasAllergy")=1
    706         I $D(MDITEM) D  ;
    707         . S G1("HasMed")=1
    708         E  S G1("HasMed")=0
    709         S G1("MedDescription")=$G(MDDESC)
    710         I $D(MDITEM) W !,"("_MDITEM_")"_MDDESC E  W !,MDDESC
    711         D RNF1TO2B^C0CRNF("GRSLT","G1")
    712         K G1
    713         Q  ; DON'T WANT TO DO THE NHIN STUFF NOW
    714         ;
    715 PATLIST ; CREATE PATIENT LISTS
    716         ; WANT TO GET RID OF PATLIST AND MOVE FUNCTION TO OTHER ROUTINES. GPL
    717         S C0QLIST(ZYR_"Patient",DFN)="" ; THE PATIENT LIST
    718         N DEMOYN S DEMOYN=1
    719         I $G(PTSEX)="" S DEMOYN=0
    720         I $G(PTDOB)="" S DEMOYN=0
    721         I $G(PTHRN)="" S DEMOYN=0
    722         I $G(PTLANG)="" S DEMOYN=0
    723         I $G(RACEDSC)="" S DEMOYN=0
    724         I $G(ETHNDSC)="" S DEMOYN=0
    725         ;I DEMOYN S C0QLIST("HasDemographics",DFN)=""
    726         ;E  S C0QLIST("FailedDemographics",DFN)=""
    727         ;S G1("Gender")=PTSEX
    728         ;S G1("DateOfBirth")=PTDOB
    729         ;S G1("HealthRecordNumber")=PTHRN
    730         ;S G1("LanguageSpoken")=$G(PTLANG)
    731         ;S G1("Race")=RACEDSC
    732         ;S G1("Ehtnicity")=$G(ETHNDSC)
    733         S G1("Problem")=PBDESC
    734         I PBDESC["No problems found" S C0QLIST(ZYR_"NoProblem",DFN)=""
    735         E  S C0QLIST(ZYR_"HasProblem",DFN)=""
    736         ;S G1("Allergies")=ALDESC
    737         I ALDESC["No Allergy" S C0QLIST(ZYR_"NoAllergy",DFN)=""
    738         E  S C0QLIST(ZYR_"HasAllergy",DFN)=""
    739         ;I $D(MDITEM) D  ;
    740                ;. S C0QLIST("HasMed",DFN)=""
    741         ;E  S G1("NoMed",DFN)=""
    742         ;S G1("MedDescription")=$G(MDDESC)
    743         Q
    744         ;
    745 NHIN    ; SHOW THE NHIN ARRAY FOR THIS PATIENT
    746         Q:DFN=137!14
    747         D EN^C0CNHIN(.G,DFN,"")
    748         ZWRITE G
    749         K G
    750         ;
    751         QUIT  ;end of WARD
    752338        ;
    753339LOCPAT(PREFIX,LOC)        ;retrieve active outpatients
     
    799385        . S PRE=ZYR_"EP-"_C0QCLNC_"-"
    800386        . D LOCPAT(PRE,C0QCLNC) ; GET THE PATIENTS
    801         . I $D(DEBUG) ZWRITE C0QLIST
     387        . I $D(DEBUG) D ZWRITE^C0QUTIL("C0QLIST")
    802388        . M C0QLIST(ZYR_"EP-ALL-PATIENTS")=C0QLIST(PRE_"Patient")
    803389        S DFN=""
    804390        S ZYR=ZYR_"EP-"
    805391        F  S DFN=$O(C0QLIST(ZYR_"ALL-PATIENTS",DFN)) Q:DFN=""  D  ; EACH PATIENT
    806         . D DEMO
     392        . D DEMO^C0QMU122
    807393        . D PROBLEM
    808394        . D ALLERGY
     
    812398        . D VITALS
    813399        D FILE ; FILE THE PATIENT LISTS
    814         ;
    815         ; Now process eRx MU measures for these patients
    816         ; Check for eRx template and code first; if they exist, run the code
    817         ; I $D(^C0PX("B","GETMEDS6")),$L($T(SOAP^C0PWS2)) DO  ; smh -cmm for now
    818         . N C0QDEBUG S C0QDEBUG=1 ; This causes the code to print out data;
    819         . D EN^C0QMUERX($$PATLN^C0QMU12(ZYR_"HasERX")) ; Pass the eRx patient list
    820         . K C0QDEBUG ; remove debug variable
    821         ;
    822400        N C0QCIEN
    823401        S ZI=""
     
    841419        . . S DFN=$P(^DGPM(PTFM,0),U,3)
    842420        . . S C0QLIST(ZYR_"Patient",DFN)=""
    843         . . D DEMO
     421        . . D DEMO^C0QMU122
    844422        . . D PROBLEM
    845423        . . D ALLERGY
     
    853431        . . D COD
    854432        . . D EDTIME
    855         . . I C0QPR D PRINT
    856         . . I C0QSS D SS
    857         . . I C0QPL D PATLIST
     433        . . I C0QPR D PRINT^C0QMU121
     434        . . I C0QSS D SS^C0QMU121
     435        . . I C0QPL D PATLIST^C0QMU121
    858436        Q
    859437        ;
     
    941519        D UPDATE^DIE("","C0QFDA","","ZERR")
    942520        I $D(ZERR) S ZZERR=ZZERR ; ZZERR DOESN'T EXIST, INVOKE THE ERROR TRAP IF TASKED
    943         ;. W "ERROR",!
    944         ;. ZWR ZERR
    945         ;. B
    946521        K C0QFDA
    947522        Q
    948523        ;
    949         ; WHAT FOLLOWS IS OLD CODE - DELETE WHEN THIS WORKS
    950         ;. . N PTNAME S PTNAME=$P(^DPT(DFN,0),U,1)
    951         ;. . S PTDOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3)) ;date of birth
    952         ;. . S PTSEX=$P($G(^DPT(DFN,0)),U,2) ;patient sex
    953         ;. . D PID^VADPT ;VADPT call to grab PISD based on PT Eligibility
    954         ;. . S PTHRN=$P($G(VA("PID")),U) ;health record number
    955         ;. . S PTRLANG=$P($G(^DPT(DFN,256000)),U) ;ptr to language file
    956         ;. . I $G(PTRLANG)'="" S PTLANG=$P(^DI(.85,PTRLANG,0),U) ;PLS extrnl
    957         ;. . S RACE=""
    958         ;. . F  D  Q:RACE=""
    959         ;. . . S RACE=$O(^DPT(DFN,.02,"B",RACE))
    960         ;. . . Q:'RACE
    961         ;. . . S RACEDSC=$P($G(^DIC(10,RACE,0)),U)
    962         ;. . N ETHNDSC
    963         ;. . N ETHNDSC S ETHNDSC=""
    964         ;. . S ETHN=""
    965         ;. . F  D  Q:ETHN=""
    966         ;. . . S ETHN=$O(^DPT(DFN,.06,"B",ETHN))
    967         ;. . . Q:'ETHN
    968         ;. . . S ETHNDSC=$P($G(^DIC(10.2,ETHN,0)),U)
    969         ;. . D LIST^ORQQPL(.PROBL,DFN,"A")
    970         ;. . S PBCNT=""
    971         ;. . F  S PBCNT=$O(PROBL(PBCNT)) Q:PBCNT=""  D
    972         ;. . . S PBDESC=$P(PROBL(PBCNT),U,2) ;problem description
    973         ;. . K PROBL
    974         ;. . D LIST^ORQQAL(.ALRGYL,DFN)
    975         ;. . S ALCNT=""
    976         ;. . F  S ALCNT=$O(ALRGYL(ALCNT)) Q:ALCNT=""  D
    977         ;. . . S ALDESC=$P(ALRGYL(ALCNT),U,2) ;allergy description
    978         ;. . K ALRGYL
    979         ;. . D COVER^ORWPS(.MEDSL,DFN)
    980         ;. . S MDCNT=""
    981         ;. . F  S MDCNT=$O(MEDSL(MDCNT)) Q:MDCNT=""  D
    982         ;. . . Q:$P(MEDSL(MDCNT),U,4)'="ACTIVE"  ;active medications only
    983         ;. . . S MDDESC=$P(MEDSL(MDCNT),U,2) ;medication description
    984         ;. . . S MDITEM=$P($G(MEDSL(MDCNT)),U,3)
    985         ;. . K MEDSL
    986         ;. . W !,"Discharge Date: ",EXDTE
    987         ;. . W !,DFN," ",PTNAME
    988         ;. . W !,"DOB: ",PTDOB," HRN: ",PTHRN
    989         ;. . W !,"Language Spoken: ",$G(PTLANG)
    990         ;. . W !,"Race: ",RACEDSC
    991         ;. . W !,"Ethnicity: ",ETHNDSC
    992         ;. . W !,"Problems: "
    993         ;. . W !,PBDESC
    994         ;. . W !,"Allergies: "
    995         ;. . W !,ALDESC
    996         ;. . W !,"Medications: "
    997         ;. . I $D(MDITEM) W !,"(",MDITEM,")",MDDESC E  W !,MDDESC
    998         ;. . W !
    999         ;Q
    1000         ;
    1001         ;
    1002         ;
    1003         ;
    1004524END     ;end of C0QPRML;
  • qrda/C0Q/trunk/p/C0QNOTES.m

    r1438 r1501  
    1 C0QNOTES        ;GPL - Utility to look up patient notes  ; 5/23/12 5:44pm
    2         ;;1.0;C0Q;;May 21, 2012;Build 43
     1C0QNOTES        ;GPL - Utility to look up patient notes  ; 7/31/12 8:17am
     2        ;;1.0;C0Q;;May 21, 2012;Build 63
    33        ;
    44        ;2011 George Lilly <glilly@glilly.net> - Licensed under the terms of the GNU
     
    112112        S GT(5,"HasMedRecon","Medication Reconcilation Complete")=""
    113113        W $$TXTALL(.G,.GT,2) ; CHECK ALL PATIENT 2'S NOTEST FOR SMOKING
    114         ZWRITE G
     114        D ZWRITE^C0QUTIL("G")
    115115        Q
    116116        ;
  • qrda/C0Q/trunk/p/C0QPQRI.m

    r1438 r1501  
    11C0QPQRI   ; GPL - GENERATES A PQRI XML FILE ; 5/23/12 2:42pm
    2         ;;1.0;C0Q;;May 21, 2012;Build 43
     2        ;;1.0;C0Q;;May 21, 2012;Build 63
    33        ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.
  • qrda/C0Q/trunk/p/C0QSET.m

    r1438 r1501  
    1 C0QSET  ;GPL - SET OPERATIONS ON LISTS ;818/11 8:50pm ; 5/23/12 5:46pm
    2         ;;1.0;C0Q;;May 21, 2012;Build 43
     1C0QSET  ;GPL - SET OPERATIONS ON LISTS ;818/11 8:50pm ; 7/31/12 8:19am
     2        ;;1.0;C0Q;;May 21, 2012;Build 63
    33        ;
    44        ;2011 George Lilly glilly@glilly.net - Licensed under the terms of the GNU
     
    2929        S B(4)=""
    3030        D UNITY("C","A","B")
    31         ZWRITE C
     31        D ZWRITE^C0QUTIL("C")
    3232        Q
    3333        ;
     
    3838        D UNITY("DELTA",PATS,MEDS)
    3939        W !,"PATIENTS WITH NO MEDS",!
    40         ZWRITE DELTA(0,*)
     40        D ZWRITE^C0QUTIL("DELTA(0,*)")
    4141        W !,"BAD POINTERS IN THE MEDS FILE",!
    42         ZWRITE DELTA(2,*)
     42        D ZWRITE^C0QUTIL("DELTA(2,*)")
    4343        Q
    4444        ;
  • qrda/C0Q/trunk/p/C0QUTIL.m

    r1438 r1501  
    1 C0QUTIL ;JJOH/ZAG/GPL - Utilities for C0Q Package ;9/2/11 4:30pm
    2         ;;1.0;C0Q;;May 21, 2012;Build 43
     1C0QUTIL ;JJOH/ZAG/GPL - Utilities for C0Q Package ; 7/31/12 7:42am
     2        ;;1.0;C0Q;;May 21, 2012;Build 63
    33        ;
    44        ;2011 Licensed under the terms of the GNU General Public License
     
    7777        Q Y
    7878            ;
     79ZWRITE(NAME)    ; Replacement for ZWRITE ; Public Proc
     80        ; Pass NAME by name as a closed reference. lvn and gvn are both supported.
     81        ; : syntax is not supported (yet)
     82        N L S L=$L(NAME) ; Name length
     83        I $E(NAME,L-2,L)=",*)" S NAME=$E(NAME,1,L-3)_")" ; If last sub is *, remove it and close the ref
     84        N ORIGLAST S ORIGLAST=$QS(NAME,$QL(NAME))       ; Get last subscript upon which we can't loop further
     85        N ORIGQL S ORIGQL=$QL(NAME)         ; Number of subscripts in the original name
     86        I $D(@NAME)#2 W NAME,"=",$$FORMAT(@NAME),!        ; Write base if it exists
     87        ; $QUERY through the name.
     88        ; Stop when we are out.
     89        ; Stop when the last subscript of the original name isn't the same as
     90        ; the last subscript of the Name.
     91        F  S NAME=$Q(@NAME) Q:NAME=""  Q:$QS(NAME,ORIGQL)'=ORIGLAST  W NAME,"=",$$FORMAT(@NAME),!
     92        QUIT
     93FORMAT(V)       ; Add quotes, replace control characters if necessary; Public $$
     94        ;If numeric, nothing to do.
     95        ;If no encoding required, then return as quoted string.
     96        ;Otherwise, return as an expression with $C()'s and strings.
     97        I +V=V Q V ; If numeric, just return the value.
     98        N QT S QT="""" ; Quote
     99        I $F(V,QT) D     ;chk if V contains any Quotes
     100        . S P=0          ;position pointer into V
     101        . F  S P=$F(V,QT,P) Q:'P  D  ;find next "
     102        . . S $E(V,P-1)=QT_QT        ;double each "
     103        . . S P=P+1                  ;skip over new "
     104        I $$CCC(V) D  Q V  ; If control character is present do this and quit
     105        . S V=$$RCC(QT_V_QT)  ; Replace control characters in "V"
     106        . S:$E(V,1,3)="""""_" $E(V,1,3)="" ; Replace doubled up quotes at start
     107        . S L=$L(V) S:$E(V,L-2,L)="_""""" $E(V,L-2,L)="" ; Replace doubled up quotes at end
     108        Q QT_V_QT ; If no control charactrrs, quit with "V"
     109        ;
     110CCC(S)  ;test if S Contains a Control Character or $C(255); Public $$
     111        Q:S?.E1C.E 1
     112        Q:$F(S,$C(255)) 1
     113        Q 0
     114RCC(NA) ;Replace control chars in NA with $C( ). Returns encoded string; Public $$
     115        Q:'$$CCC(NA) NA                         ;No embedded ctrl chars
     116        N OUT S OUT=""                          ;holds output name
     117        N CC S CC=0                             ;count ctrl chars in $C(
     118        N C                                     ;temp hold each char
     119        F I=1:1:$L(NA) S C=$E(NA,I) D           ;for each char C in NA
     120        . I C'?1C,C'=C255 D  S OUT=OUT_C Q      ;not a ctrl char
     121        . . I CC S OUT=OUT_")_""",CC=0          ;close up $C(... if one is open
     122        . I CC D
     123        . . I CC=256 S OUT=OUT_")_$C("_$A(C),CC=0  ;max args in one $C(
     124        . . E  S OUT=OUT_","_$A(C)              ;add next ctrl char to $C(
     125        . E  S OUT=OUT_"""_$C("_$A(C)
     126        . S CC=CC+1
     127        . Q
     128        Q OUT
    79129END     ;end of C0QUTIL
Note: See TracChangeset for help on using the changeset viewer.